

;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO




;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPP         PPP      111111            111111
;	PPP         PPP      111111            111111
;	PPP         PPP      111111            111111
;	PPP         PPP         111               111
;	PPP         PPP         111               111
;	PPP         PPP         111               111
;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                  111111111         111111111
;	PPP                  111111111         111111111
;	PPP                  111111111         111111111



;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;   OOO         OOO   OOO         OOO
;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO
;      OOOOOOOOO         OOOOOOOOO




;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPP         PPP      111111            111111
;	PPP         PPP      111111            111111
;	PPP         PPP      111111            111111
;	PPP         PPP         111               111
;	PPP         PPP         111               111
;	PPP         PPP         111               111
;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPPPPPPPPPPP            111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                     111               111
;	PPP                  111111111         111111111
;	PPP                  111111111         111111111
;	PPP                  111111111         111111111

	.=100000		;ORIGIN IN USER AREA
;OPEN A FILE OR A DEVICE (THE FIRQB POINTER IS IN R4 ON ENTRY)
;THE FIRQB IS RETURNED TO USER IF OPEN FAILS (IOSTS HAS ERROR CODE, IF ANY)
;OTHERWISE THE FIRQB IS NOT RETURNED

OPEN:	JSR	PC,@#FQTOFC	;GET THE ADDRESS OF FCB
	BEQ	.+4		;IF CHANNEL OPEN NOW, THAT'S BAD
	FIERR+	NOTCLS		;SO TELL HIM NO SOAP.

	JSR	R5,NAMDEV	;GET DEVICE DDB FROM NAME
	BR	OPEN07		;IT'S A DSK FILE
	BEQ	OPEN12		;HE ALREADY OWNS IT
	JSR	PC,ASSI10	;ASSIGN IT TO HIM IF AVAILABLE
OPEN12:	INCB	DDCNT(R1)	;UPDATE ACCESS COUNT
	MOV	R1,(R3)		;STORE DDB POINTER IN I/O BLK
	MOV	@#FIQUE,R0	;NOW GET NEXT FIRQB ADDRESS
	MOV	(R0),@#FIQUE	;AND PUT AT START OF QUEUE
	BUFFER,	RETSML		;RETURN THE FIRQB
	BR	OPEN14		;AND COMPLETE OPEN

OPEN07:	MOV	R3,R5		;CLOSE RETURNS POINTER TO IO BLOCK SLOT IN R3
	MOV	R4,R1		;GET POINTER TO FIRQB IN R1
	ADD	#6,R1		;POINT TO PPN IN FIRQB
	MOV	R1,R3		;SAVE POINTER TO PPN IN FIRQB
	JSR	R5,@#DIRSIR	;AND SEARCH
	+	3		;FOR 3 WORD FILE NAME
	BCS	OPEN09		;NO - SO IT'S NOT THERE!
	ADD	#USTAT,R1	;POINT TO FILE STATUS BYTE
	TSTB	(R1)+		;IT'S THERE - IS IT DELETED?
	BMI	OPEN09		;YES - SO IT'S NOT THERE
	BNE	OPEN02		;IF IT'S A UFD, DON'T OPEN IT
	MOV	R4,(R5)		;STORE FCB POINTER IN I/O BLK
	MOVB	(R1)+,-(SP)	;PROTECTION BITS
	CLR	R0		;ASSUME OPENER IN OWNER FOR NOW
	TST	(R3)		;IS HE THE OWNER?
	BEQ	OPEN01		;YES, SO SE OWNER PROTECTION
	CMP	(R3)+,@#FIUSER	;IS JOB OWNER
	BEQ	OPEN01		;YES WE HAVE BITS
	INC	R0		;NOTE THAT HE ISN'T THE OWNER
	ROR	(SP)		;NO - SHIFT IT RIGHT
	ROR	(SP)		;TWO PLACES - FOR GROUP PROTECTION
	CMPB	-(R3),@#FIUSER+1	;CHECK GROUP MATCH
	BEQ	OPEN01		;YES - SET GROUP CODES
	ROR	(SP)		;NO - SET WORLD AT
	ROR	(SP)		;LARGE PROTECTION
OPEN01:	BIC	#-3-1,(SP)	;CLEAR ALL BUT LOW TWO BITS
	ASL	(SP)		;SHIFT INTO PROTECT BIT POSITIONS IN FCB
	BIS	R0,(SP)		;NOW SET UP FCOWNR BIT AS NOTED
	CMPB	(SP),#7		;READ,WRITE PROTECT+NOT OWNER?
	BEQ	OPEN06		;YES--DON'T LET HIM OPEN IT THEN
	SWAB	(SP)		;PUT PROTECTION IN HIGH BYTE
	CLRB	(SP)		;AND PUT FILE HANDLER INDEX IN LOW BYTE
	TSTB	(R1)		;IS ANYBODY LOOKING?
	BEQ	OPEN05		;NO, SO HE CAN WRITE AS PERMITTED...
	BIS	#2000,(SP)	;YES, SO HE CAN'T WRITE, REGARDLESS
OPEN05:	ADD	#3,R4		;AND NOW POINT TO FCASN IN FCB
	MOV	R1,-(SP)	;COMPUTE ADDRESS IN SEGMENT OF NAME BLOCK
	SUB	#FIBUF+UACNT,(SP)	;BYTE INDEX
	ASR	(SP)		;DIVIDE BY 2 FOR WORD INDEX
	MOVB	(SP)+,(R4)+	;STORE IN FCB
	TST	(R4)+		;SKIP TO NEXT LOGICAL BLOCK ENTRY
	CLR	(R4)+		;AND CLEAR IT
	CLR	(R4)+		;FIRST LOGICAL BLOCK IN WINDOW=0
	MOV	@#FIBPHS,(R4)+	;STORE SEGMENT # OF NAME BLOCK
	INC	(R1)+		;UPDATE ACCESS COUNT
	MOV	(R1)+,R0	;GET ACCOUNTING BLOCK ADDRESS
	MOV	(R1),-(SP)	;PUSH RETRIEVAL BLOCK ADDR.
	JSR	PC,@#GETLKS	;GET ACCOUNTING BLOCK
	TST	(R0)+		;SKIP OVER MARKER
	MOV	@#DATE,(R0)+	;UPDATE LAST ACCESS DATE
	MOV	(R0)+,-10(R4)	;PUT FILE SIZE IN FCB
	MOV	(SP)+,R0	;GET UFD ADDRESS - RETRIEVAL BLK.
	JSR	PC,@#GETLKS	;AND GET RETRIEVAL BLOCK
	MOV	@#FIBPHS,(R4)+	;PHYSICAL SEG # OF WINDOW
	CLR	(R4)+		;CLEAR ERROR WORD IN FCB
OPEN03:	MOV	(R0)+,(R4)+	;FROM DIRECTORY
	BIT	R4,#36		;AT END OF WINDOW?
	BNE	OPEN03		;NOT YET
	TST	@#FIBSTA	;IS BUFFER WORTH SAVING?
	BEQ	OPEN04		;NOPE, SO DON'T
	JSR	PC,@#WRITE	;YES, SO SAVE IT NOW
OPEN04:	MOV	@#FIQUE,R0	;MANUALLY UNQUEUE NEXT REQUEST
	MOV	(R0),@#FIQUE	;NEXT REQUEST
	MOV	(SP)+,(R0)	;SET UP FIRST WORD OF FCB FROM STACK
OPEN14:	MOVB	@#FIJOB,R5	;GET THE JOB WE SERVICED
	BIS	#JSFIP,JBSTAT(R5)	;GET HIM OUT OF WAIT
	TST	@#FIQUE		;SET UP CONDITIONS FOR EXIT ROUTINE
	JMP	@#FIEX03	;AND EXIT WEIRDLY

OPEN06:	CLR	(R5)		;REMOVE BOGUS FCB POINTER
OPEN02:	FIERR+	PRVIOL		;PROTECTION VIOLATION
OPEN09:	FIERR+	NOSUCH		;CAN'T FIND THAT FILE
;ROUTINE TO DEASSIGN A DEVICE-------------------------------------------
;UNKNOWN DEVICES TRAP TO FIERR; UNOWNED DEVICES ARE NOT DEASSIGNED

DEAS00:	JSR	R5,NAMDV0	;CONVERT NAME TO DDB ADDRESS
	BR	DEAS02		;DEVICE WAS DSK....
	BNE	DEAS02		;DOESN'T OWN DEVICE, SO DON'T DEASSIGN
	BIC	#DDASN,DDCNT(R1) ;CLEAR THE ASSIGNMENT BIT
	BNE	DEAS02		;IF NOT INIT'ED, CLEAR OUT DDB
	MOV	@#FIJBDA,R2	;GET ADDRESS OF JOB DATA BLOCK
	MOV	DDTIME(R1),R4	;GET TIME DEVICE WAS ASIGNED
	SUB	@#TIME,R4	;LESS TIME IT IS NOW
	BPL	.+6		;WAS IT ASSIGNED YESTERDAY?
	ADD	#1440.,R4	;YES, SO FUDGE FOR NEGATIVE TIME
	ADD	R4,JDDEV(R2)	;ACCUMULATE INTO JOB'S DEVICE TIME
	CLRB	DDJBNO(R1)	;AND REMOVE HIS NUMBER FROM DDB
DEAS02:	RTS	PC		;IT WAS INIT'ED; LET CLOSE DO IT.




;ROUTINE TO ASSIGN A DEVICE---------------------------------------------
;IF JOB ALREADY OWNS IT, WE MERELY TURN ON "ASSIGN" BIT
;OTHERWISE, IF DEVICE IS AVAILABLE, WE GIVE IT TO JOB
;AND NOTE THE TIME IN THE DDB

ASSIGN:	JSR	R5,NAMDV0	;CONVERT RADIX50 NAME TO DDB ADDRESS
	BR	ASSI02		;HE CAN ASSIGN DSK ALL HE WANTS
	BEQ	ASSI01		;IF HE ALREADY OWNS IT, SET DDASN
	JSR	PC,ASSI10	;GIVE IT TO HIM IF IT'S AVAILABLE
ASSI01:	BIS	#DDASN,DDCNT(R1);INDICATE ASSIGNMENT
ASSI02:	RTS	PC		;RETURN


;GIVE HIM THE DEVICE IF IT'S AVAILABLE--------

ASSI10:	TSTB	DDJBNO(R1)	;DOES ANYONE OWN DEVICE?
	BEQ	.+4		;IF NOT, HE CAN HAVE IT
	FIERR+	NOTAVL		;IF SO, HE CAN'T

	MOV	@#TIME,DDTIME(R1) ;NOTE TIME WE GAVE IT TO HIM
	MOVB	@#FIJOB,DDJBNO(R1);AND WHOM WE GAVE IT TO.
	CLR	DDCNT(R1)	  ;INIT COUNT AND ASSIGN BITS = 0
	RTS	PC		  ;RETURN
;ROUTINE TO GENERATE A DDB ADDRESS FROM A RADIX 50 DEVICE NAME
;CALL	JSR	R5,NAMDEV	;R4 HAS FIRQB ADDRESS
;	BR	DISK		;DEVICE SPECIFIED WAS DSK:
;	...	RETURN		;Z=1 IF JOB OWNS DEVICE, 0 OTHERWISE
;				;R1 CONTAINS DDB ADDRESS
;RETURN IS THROUGH FIERR FOR NON-EXISTANT DEVICES

NAMDV0:	TST	FQDEV(R4)	;DID HE FORGET ":" AFTER DEV
	BNE	NAMDEV		;NOPE--GO ASSIGN IT
	MOV	FQNAM1(R4),FQDEV(R4)	;YES--HELP HIM OUT A LITTLE
NAMDEV:	MOV	FQDEV(R4),R1	;GET DEVICE NAME
	BEQ	NAMD07		;NULL DEVICE NAME= DSK
	CMP	R1,#R50DSK	;DSK SPECIFIED EXPLICITLY?
	BEQ	NAMD07		;YES--TAKE DSK EXIT
	TST	(R5)+		;IT'S GOT TO BE A DEVICE OTHER THAN DSK
	MOV	#DEVNAM+2,R0	;POINT TO DEVICE NAME TABLE
NAMD02:	CMP	R1,(R0)+	;AND SEARCH FOR THE NAME
	BEQ	NAMD01		;FOUND IT!
	TST	(R0)		;NOT YET--AT END OF LIST?
	BNE	NAMD02		;NO--KEEP GOING
NAMD06:	FIERR	!NODEVC		;YES--ALL IS LOST

NAMD01:	MOV	FQDEVN(R4),R2		;GET DEVICE NUMBER, IF SPECIFIED
	BEQ	NAMD03			;IT WASN'T--CHECK FOR "TTY"
NAMD05:	JSR	PC,RAD50B		;CONVERT TO BINARY UNIT #
	BCS	NAMD06			;WEIRD CHARACTER IN NUMBER
	CMP	DEVCNT-DEVNAM-4(R0),R1	;IS THIS A VALID UNIT #
	BLO	NAMD06			;NO, SO COMPLAIN
	ASL	R1			;NOW COMPUTE DEVTBL POINTER
	ADD	DEVPTR-DEVNAM-4(R0),R1	;ORIGIN OF DEVICE'S ENTRIES
	MOV	(R1),R1			;GET DDB ADDRESS
NAMD04:	CMPB	DDJBNO(R1),@#FIJOB	;SET STATUS FOR RETURN
NAMD07:	RTS	R5			;AND RETURN

NAMD03:	CMP	R1,#R50TTY	;IF HE SAID "TTY:" HE MEANS HIS OWN
	BNE	NAMD05		;HE DIDN'T SAY "TTY"
	MOV	@#FIJBDA,R1	;GET HIS PJOB DATA ADDRESS
	MOV	@(R1)+,R1	;GET HIS TTY DDB ADDRESS
	BR	NAMD04		;SET STATUS AND GET OUT
;	RADIX 50 TO BINARY (OCTAL) CONVERSION ROUTINE
;	INPUT IN R2 
;	OUTPUT IN R1
;	REGISTERS USED--R1
;	CALL WITH JSR  PC,RAD50B
;	RETURNS WITH C SET IF NOT ALL NUMERIC OR BLANK

RAD50B:	JSR	R5,@#SAVREG	;SAVE THE REGISTERS ON SP STACK
	CLR	R0		;CLEAR THE ERROR INDICATOR
	MOV	R2,R3		;FOR COMPATABILITY PURPOSES
	CLR	-(SP)		;MAKE A TWO WORD
	CLR	-(SP)		;  OR 4 CHARACTER BUFFER
	MOV	SP,R1		;ADDRESS OF THE WORK AREA
	MOV	#R50TBL,R4	;SET UP TABLE OF POWERS OF 40
R50B01:	CLR	R2		;DIGIT TO BE
R50B02:	CMP	R3,(R4)		;SEE IF DIVISION DONE YET
	BLO	R50B03		;BRANCH IF COMPLETED
	SUB	(R4),R3		;SUBRTACT
	INC	R2		;COUNT IT IN THE DIGIT
	BR	R50B02		;LOOP FOR MORE

R50B03:	SUB	#36,R2		;MAKE INTO BINARY
	BLT	R50B06		;BRANCH IF ILLEGAL
R50B04:	MOVB	R2,(R1)+	;STORE THE CURRENT DIGIT
	TST	-(R4)		;SEE IF DONE
	BNE	R50B01		;LOOP IF MORE TO DO
	COMB	(R1)+		;SET END FLAG
	CMP	-(R1),-(R1)	;BACK UP TO THE START
R50B05:	TSTB	(R1)		;SEE IF THERE
	BLT	R50B07		;BRANCH IF ALL DONE
	ASL	R3		;MULTIPLY BY
	ASL	R3		;  EIGHT TO FORM
	ASL	R3		;    THE BINARY NUMBER
	MOVB	(R1)+,R2	;GET THE DIGIT
	ADD	R2,R3		;A TWO WORD ADDB INSTRUCTION
	BR	R50B05		;LOOP FOR MORE

R50B06:	CMP	R2,#-36		;SEE IF BLANK
	BEQ	R50B04		;IF BLANK THEN OK
	MOV	#100000,R0	;ELSE SET AN ERROR
R50B07:	CMP	(SP)+,(SP)+	;POP WORK AREA
	ASL	R0		;SET C FOR ERROR
	MOV	R3,2(SP)	;STORE IN R1 TO BE RETURNED
	JSR	R5,@#RESREG	;AND RESTORE REGISTERS
	RTS	PC		;AND RETURN

	.WORD	0
	.WORD	1.		;40.^0
	.WORD	40.		;40.^1
R50BTB:	.WORD	1600.		;40.^2

R50TBL	=FIPBUF+R50BTB-OPEN	;RELOCATED TABLE ADDRESS
.SIZE5	=.-OPEN
;CREATE A USER FILE
;CALL:	JSR	PC,CREATE	;FIRQB ADDRESS IN R4
;	...	RETURN

;THE SIZE OF THE FILE TO BE CREATED IS SPECIFIED IN FQSIZE.  IF IT
;IS 0 LENGTH, THEN THE NAME BLOCK, ACCOUNTING BLOCK, AND RETRIEVAL
;BLOCKS ARE ALLOCATED IN THE DIRECTORY, BUT NO ACTUAL SEGMENTS ARE
;ALLOCATED TO THE FILE.  SINCE THE "GETHOL" ROUTINE LOOKS FOR
;DIRECTORY BLOCKS IN WHICH THE FIRST TWO WORDS ARE 0, IT IS
;NECESSARY TO PUT A 1 IN THE FIRST WORD OF THE RETRIEVAL BLOCK IN THIS
;CASE, IN ORDER THAT THE BLOCK BE PASSED OVER IN HOLE SEARCHES.  THUS
;ROUTINES WHICH GO CHAINING THROUGH THE RETRIEVAL BLOCKS HAVE TO BE
;CAREFUL TO DISTINGUISH THE 0 LENGTH CASE (REFERRED TO AS A BOGUS BLOCK)
;FROM THE RETRIEVAL LINK CASE.  A WORD TO THE WISE...
;EXIT THROUGH EXTEND FOR FILES >1 SEGMENT
;EXIT THROUGH FIERR FOR ERRORS

CREATE:	MOV	FQDEV(R4),R0	;GET DEVICE NAME, IF ANY
	BEQ	CRE805		;NONE, SO MUST BE DISK
	CMP	R0,#R50DSK	;IF PRESENT, IS IT DSK?
	BNE	CRE806		;NO, SO CREATE "SUCCEEDED"
CRE805:	JSR	R5,RENSIR	;SEARCH FOR FILE IN DIRECTORY
	+	FQPPN1		;POSITION IN FIRQB
	BCS	CRE802		;DID WE FIND IT?
	MOV	R1,R0		;YES - GET BUFFER ADDRESS IN R0
	TST	UACNT(R1)	;YES - IS IT IN USE?
	BEQ	.+4		;IF IN USE, THAT'S NOT FAIR...
	FIERR	!INUSE		;SO WE WON'T LET HIM DO IT. HAH!

	BITB	#2,UPROT(R1)	;USER WRITE PROTECTED?
	BEQ	.+4		;HE'S TRYING TO--
CRE807:	FIERR	!PRVIOL		;WE WON'T LET HIM DO THAT EITHER

	BITB	#100,USTAT(R1)	;IS HE RECREATING A UFD?
	BNE	CRE807		;YES--HE SHOULD DELETE USER FIRST!!
	JSR	PC,@#DELEET	;IT'S OK TO DELETE THE CURRENT FILE
	BR	CREATE		;AND NOW TRY AGAIN

CRE808:	JSR	PC,(R1)		;FILE OF 0 LENGTH--MARK RETRIEVAL BLOCK
	INC	(R0)		;BY SETTING BOGUS BIT
	BR	CRE801		;AND DOING REST OF CREATE STUFF

CRE809:	MOV	(R0),R0		;FILE OF LENGTH>1--CALL EXTEND
	JSR	PC,(R1)		;WHILE FORCING OUT OLD LINK
	JMP	@#EXT00		;NOW EXTEND THE FILE

CRE802:	MOV	#GETHOL,R5	;PROVIDE ONE WORD CALLS
	MOV	#GETLKS,R1	;FOR COMMONLY USED
	MOV	R0,-(SP)	;SAVE UFD ADDRESS OF LAST LINK
	CLR	R0		;START HOLE SEARCH AT UFD 0
	JSR	PC,(R5)		;GET A HOLE
	BCC	.+4		;DIRECTORY FULL
CRE804:	FIERR	!NOROOM		;TOUGH LUCK!
	MOV	R0,-(SP)	;SAVE UFD ADDRESS
	ADD	#20,R0		;DON'T POINT TO DAME HOLE
	JSR	PC,(R5)		;GET ANOTHER HOLE
	BCS	CRE804		;DIRECTORY FULL
	MOV	R0,-(SP)	;SAVE UFD ADDRESS
	ADD	#20,R0		;DON'T GET SAME HOLE
	JSR	PC,(R5)		;GET STILL A THIRD HOLE!
	BCS	CRE804		;DIRECTORY FULL
	MOV	R0,-(SP)	;SAVE THIRD HOLE
	TSTB	FQSIZ(R4)	;IS THIS A 0 LENGTH FILE??
	BEQ	CRE808		;YES--DON'T GET A SEGMENT THEN
	JSR	PC,@#GETSEG	;GET A SEGMENT FROM SAT IN R3
	BNE	.+4		;IF THERE ARE NO SEGMENTS LEFT, TOUGH!
	FIERR	!NOROOM		;TOO BAD.  0 LENGTH FILES ONLY...

	JSR	PC,(R1)		;GET THE LINK - RETRIEVAL BLOCK
	CLR	(R0)+		;LINK TO NEXT WINDOW =0
	MOV	R3,(R0)		;STORE SEGMENT #
CRE801:	MOV	2(SP),R0	;GET SECOND BLOCK
	JSR	PC,(R1)		;GET LINK - ACCOUNTING BLOCK
	COM	(R0)+		;MARK AS ACCOUNTING BLOCK
	MOV	@#DATE,(R0)+	;AND SET TODAY AS MOST RECENT ACCESS
	CLR	-(SP)		;SIZE WILL BE 1 SEGMENT OR 0 SEGMENTS
	TSTB	FQSIZ(R4)	;FOR THE TIME BEING....
	BEQ	.+4		;0 SEGMENTS REQUESTED
	INC	(SP)		;AT LEAST ONE DESIRED....
	MOV	(SP)+,(R0)+	;STORE IN USIZ
	MOV	@#DATE,(R0)+	;CREATION DATE
	MOV	@#TIME,(R0)+	;CREATION TIME
	MOV	4(SP),R0	;GET FIRST HOLE
	JSR	PC,(R1)		;GET LINK - NAME BLOCK INTO CORE
	CLR	(R0)+		;POINTER TO NEXT = 0
	MOV	R4,R5		;FIRQB POINTER
	ADD	#10,R5		;POINT TO FILE NAME IN FIRQB
	MOV	(R5)+,(R0)+	;COPY NAME
	MOV	(R5)+,(R0)+	;FROM FIRQB
	MOV	(R5)+,(R0)+	;TO DIRECTORY
	MOV	#36000,(R0)+	;NOW SET PROTECTION - USER R/W
	CLR	(R0)+		;ACCESS COUNT = 0
	MOV	(SP)+,2(R0)	;RETRIEVAL BLOCK ADDRESS TO BLOCK
	MOV	(SP)+,(R0)	;ACCOUNTING BLOCK ADDRESS TO BLOCK
	MOV	2(SP),R0	;GET FORMER LAST LINK
	JSR	PC,(R1)		;INTO CORE
	MOV	(SP)+,(R0)	;AND PUT NEW LAST LINK IN POINTER
	TST	(SP)+		;CLEAR THE STACK
	MOV	SP,@#FIBSTA	;FORCE BUFFER OUT
	TSTB	FQSIZ(R4)	;STILL MORE TO DO FOR 0 SEGMENTS?
	BEQ	CRE806		;NOPE
	DECB	FQSIZ(R4)	;REMOVE 1 SEGMENT FROM COUNT
	BNE	CRE809		;IF ZERO, WE'RE DONE
CRE806:	RTS	PC		;ALL DONE
;ROUTINE TO CREATE A .TMP FILE WITH UNIQUE NAME
;THE NAME IS A FUNCTION OF THE JOB #

CRTMP:	MOVB	@#FIJOB,R0	;GET JOB #
	ASR	R0		;DIVIDE BY 2 FOR JOB #
	ADD	#3150,R0	;JOB 1 WILL BE "AAA"
	MOV	R0,FQNAM1(R4)	;STICK FIRST WORD OF NAME IN FIRQB
	CLR	FQNAM1+2(R4)	;SECOND WORD IS SPACES
	CLR	FQPPN1(R4)	;BETTER SAFE THAN SORRY
	CLR	FQDEV(R4)	;JUST IN CASE
	BR	CRE805		;NOW GO CREATE IT


;ROUTINE TO CREATE AN NEW USER I.D.
;CALLED WITH FIRQB POINTER IN R4
;IF USER IS NOT IN UNDER [1,1], HE GETS A PROTECTION VIOLATION

PASSWD:	CMP	@#FIUSER,#401	;IN UNDER [1,1]?
	BNE	CRE807		;NO, SO IT'S A PROTECTION VIOLATION
	MOVB	#1,FQSIZ(R4)	;MAKE UFD 1 SEGMENT LONG
	JSR	PC,CREATE	;NOW CREATE A PLAIN, ORDINARY FILE
	MOV	(R0),R0		;WE GOT BACK, SO IT'S CREATED
	MOV	R0,-(SP)	;SAVE ADDRESS OF NAME BLOCK
	JSR	PC,(R1)		;GET THE NAME BLOCK BACK
	MOV	UAR(R0),R0	;GET THE UFD ADDRESS OF RETRIEVAL BLOCK
	JSR	PC,(R1)		;AND GET THE RETRIEVAL BLOCK
	TST	(R0)+		;POINT TO SEGMENT # IN BLOCK
	MOV	(R0),R5		;NOW GET THE UFD SEGMENT #
	CLR	(R0)		;AND WIPE IT OUT OF THE DIRECTORY
	MOV	(SP)+,R0	;NOW GET THE NAME BLOCK ADDRESS
	JSR	PC,(R1)		;AND GET THE NAME BLOCK
	MOV	R5,UAR(R0)	;PUT STARTING SEGMENT OF UFD IN NAME BLOCK
	MOV	#37500,USTAT(R0);SET STATUS AND PROTECTION
	MOV	R5,R2		;NOW SET UP THE DIRECTORY
	JSR	PC,@#READSV	;BY READING IN THE UFD SEGMENT
	MOV	#FIBUF,R0	;AND CLEARING IT OUT
	MOV	#256.,R1	;...ALL 256. WORDS OF IT...
	CLR	(R0)+		;ONE WORD
	SOB	R1,.-4		;AT A TIME
	COM	@#FIBUF+2	;SET MARKER FOR DUMMY NAME BLOCK
	MOV	R5,@#UFDEX	;AND SET UP UFD INDEX IN SEGMENT
REN02:	JMP 	@#FIEXS		;ALL DONE--SAVE SEGMENT AND EXIT
;ROUTINE TO RENAME A FILE
;CALL WITH FIRQB POINTER IN R4
;ONLY OWNER CAN RENAME FILES

RENAME:	MOV	FQDEV(R4),R0	;GET DEVICE NAME, IF SPECIFIED
	BEQ	REN04		;IT WASN'T, SO ASSUME DSK:
	CMP	R0,#R50DSK	;WAS IT "DSK:"
	BEQ	.+4		;YES--OK
REN03:	FIERR	!BADNAM		;GIVE HIM A BAD (RE) NAME

REN04:	JSR	R5,RENSIR	;SEARCH FOR OLD NAME
	+	FQPPN1		;OLD PPN SLOT IN FIRQB
	BCS	REN01		;NOT THERE - ERROR
	MOV	R0,-(SP)	;SAVE UFD ADDRESS
	CMP	FQNAM1+0(R4),FQNAM2+0(R4)	;SAME NAME?
	BNE	REN06				;NO--LOOK IT UP
	CMP	FQNAM1+2(R4),FQNAM2+2(R4)	;KEEP TRYING...
	BNE	REN06				;NOT A MATCH
	CMP	FQNAM1+4(R4),FQNAM2+4(R4)	;EXTENTIONS, TOO?
	BEQ	REN05				;JUST CHANGE THE PROTECTION
REN06:	JSR	R5,RENSIR	;SEARCH FOR NEW NAME
	+	FQPPN2		;NEW PPN SLOT IN FIRQB
	BCS	.+4		;IF IT'S NOT THERE, OK
	FIERR	!FIEXST		;DON'T ALLOW DUPLICATE NAME!

REN05:	MOV	(SP)+,R0	;OK TO RENAME - GET NAME BLOCK
	JSR	PC,@#GETLNK	;BACK INTO BUFFER
	TST	(R0)+		;SKIP OVER LINK
	ADD	#FQPPN2+2,R4	;POINT TO NEW NAME
	MOV	(R4)+,(R0)+	;COPY NAME
	MOV	(R4)+,(R0)+	;COPY NEXT WORD
	MOV	(R4)+,(R0)+	;AND EXTENSION
	TSTB	(R0)+		;POINT TO UFD PROTECTION BYTE
	TSTB	(R4)+		;PROTECTION SPECIFIED?
	BPL	.+4		;NO, SO DON'T CHANGE PROTECTION
	MOVB	(R4),(R0)	;YES, SO PUT IN NEW PROTECTION
	BR	REN02		;FORCE BUFFER AND EXIT

;ROUTINE TO SET UP SEARCH FOR RENAME

RENSIR:	MOV	R4,R1		;FIRQB ADDRESS
	ADD	(R5)+,R1	;+OFFSET TO PPN
	CLR	(R1)		;ONLY THIS OWNER, PLEASE
	TST	2(R1)		;IS FIRST WORD IF FILENAME = 0
	BEQ	REN03		;YES----TILT!!!
	JSR	R5,@#DIRSIR	;SO SEARCH ALREADY!
	+	3		;THREE WORDS IN BLOCK
	RTS	R5		;RETURN WITH THE GOODS
;ROUTINE TO AID EDITOR IN HANDLING "OLD" COMMAND
;WE CHECK TO SEE IF FILE.BAS EXISTS, OR IF INPUT DEVICE IS VALID
;IF SOURCE SEEMS REASONABLE, WE GIVE IOSTS=0, ELSE IOSTS=NOSUCH

OLDF:	MOV	FQDEV(R4),R0	;IS DEVICE DSK?
	BEQ	OLDF01		;BY IMPLICATION, YES
	CMP	R0,#R50DSK	;BY EXPLICATION???
	BEQ	OLDF01		;YES--CHECK FOR FILE PRESENT
OLDF02:	RTS	PC		;RETURN NO ERROR--PROCEED WITH OLD

OLDF01:	MOV	#R50BAS,FQEXT(R4)	;SET UP .BAS EXTENTION
RUNF03:	MOV	R4,R1		;AND SET UP DIRECTORY SEARCH
	ADD	#6,R1		;POINT TO PPN IN FIRQB
	JSR	R5,@#DIRSIR	;AND SEARCH
	+	3		;FOR A 3 WORD ENTRY
	BCC	OLDF02		;FOUND IT--PROCEED WITH OLD
REN01:
RUNF01:	FIERR	!NOSUCH		;NOT THERE--YELL!

;AID EDITOR IN DOING "RUN" COMMAND
;IF FILE SPECIFIED IS NOT DSK:*.BAC, THEN FORCE AN "OLD" FIRST
;ELSE PROCEED WITH "RUN"

RUNF:	MOV	FQDEV(R4),R0	;GET THE DEVICE
	BEQ	RUNF02		;IT IS IMPLIED DSK
	CMP	R0,#R50DSK	;IS IT EXPLICIT DSK:?
	BNE	RUNF01		;NO--DON'T LET RUN PROCEED
RUNF02:	MOV	#R50BAC,FQEXT(R4)	;SET UP .BAC EXTENTION
	BR	RUNF03		;AND SEARCH FOR FILE


.SIZE3	=.-CREATE
.	=CREATE+1000		;JUST IN CASE WE MADE A MISTEAK
;ROUTINE TO GET INFORMATION ON THE N'TH LOGICAL ENTRY IN DIRECTORY
;ENTERED THROUGH EMT HANDLER FOR "DIRECT"
;FQFILE AND FQSIZE CONTAIN THE LOGICAL INDEX OF THE DIRECTORY ITEM
;WHERE THE FIRST ENTRY IN THE DIRECTORY IS ITEM # 0
;FQPPN1 CONTAINS THE PPN OF THE DIRECTORY WE ARE CONCERNED WITH

DIRECT:	MOV	FQDEV(R4),R0	;GET DEVICE NAME
	BEQ	DIRE06		;DISK IS IMPLIED
	CMP	R0,#R50DSK	;IS DSK EXPLICIT?
	BNE	DIRE02		;NO--GIVE HIM NOSUCH
DIRE06:	MOV	R4,R1		;FIRQB ADDRESS TO R1
	CMP	(R1)+,(R1)+	;POINT TO DIRECTORY INDEX
	MOV	(R1)+,R3	;GET LOGICAL INDEX
	JSR	PC,@#GETUFD	;GET THE APPROPRIATE UFD ENTRY
	MOV	@#FIBUF,R0	;GET ADDRESS OF FIRST NAME BLOCK
	BEQ	DIRE02		;IF THERE IS A FIRST LINK....
DIRE01:	JSR	PC,@#GETLNK	;GET THE FIRST DIRECTORY LINK
	BEQ	DIRE02		;NON EXISTENT DIRECTORY ENTRY
	TSTB	USTAT(R0)	;IS THE FILE TO BE DELETED?
	BMI	DIRE04		;YES--DON'T COUNT IT
	BEQ	DIRE05		;IT'S NOT A UFD EITHER---
	CMP	@#FIUSER,#401	;IT IS A UFD--IS THIS [1,1]
	BNE	DIRE04		;IF IT ISN'T, DON'T GIVE HIM THE INFO
DIRE05:	DEC	R3		;IS THIS THE ONE WE WANT?
	BMI	DIRE03		;YES--COPY INFO
DIRE04:	MOV	(R0),R0		;NO--GET NEXT LINK
	BNE	DIRE01		;AND KEEP LOOKING IF THERE'S ANYTHING LEFT
DIRE02:	FIERR+	NOSUCH		;WE CAN'T SEEM TO FIND THAT FILE

DIRE03:	ADD	#10,R4		;R4 POINTS TO FILE NAME IN FIRQB
	TST	(R0)+		;SKIP OVER LINK WORD
	MOV	(R0)+,(R4)+	;COPY NAME
	MOV	(R0)+,(R4)+	;MORE NAME
	MOV	(R0)+,(R4)+	;EXTENSION
	MOVB	1(R0),R5	;GET PROTECTION BYTE
	MOV	4(R0),R0	;AND ACCOUNTING BLOCK ADDRESS
	JSR	PC,@#GETLNK	;AND GET POINTER TO IT
	TST	(R0)+		;SKIP OVER LINK MARKER
	MOV	(R0)+,-(SP)	;SAVE LAST ACCESS DATE
	MOV	(R0)+,(R4)+	;COPY SIZE
	MOV	R5,(R4)+	;COPY PROTECTION AS WORD
	MOV	(SP)+,(R4)+	;COPY DATE OF LAST ACCESS
	MOV	(R0)+,(R4)+	;CREATION DATE
	MOV	(R0)+,(R4)+	;CREATION TIME
	RTS	PC		;AND RETURN

;ROUTINE TO DELETE A FILE, GIVEN IT'S NAME
;WE CHECK TO MAKE SURE FILE IS NOT WRITE PROTECTED AGAINST USER

DELNAM:	MOV	@#FIJBDA,R0	;IF HE'S NOT LOGGED IN....
	TST	JDPPN(R0)	;THEN HE SHOULDN'T DELETE STUFF
	BEQ	DELN06		;SO MAKE HIM THINK HE'S HAPPY
DELN00:	MOV	FQDEV(R4),R0	;GET DEVICE NAME--IS IT DISK IMPLIED?
	BEQ	DELN05		;YES-DELETE IS HONORABLE
	CMP	R0,#R50DSK	;IS IT DSK BY EXPLICIT REFERENCE?
	BNE	DELN06		;NO; CONSIDER FILE DELETED
DELN05:	MOV	R4,R1		;SET UP CALL TO SEARCH ROUTINE
	ADD	#6,R1		;POINT TO PPN OF OWNER
	TST	2(R1)		;IS FILE NAME VALID?
	BNE	.+4		;IF ALL SPACES, IT'S NOT
	FIERR	!BADNAM		;COMPLAIN

	JSR	R5,@#DIRSIR	;SEE IF FILE EXISTS
	+	3		;ALL THREE WORDS OF ITS NAME
	BCC	.+4		;WE FOUND IT!
DELN03:	FIERR	!NOSUCH		;IT'S NOT THERE (OR IT'S DELETED ALREADY)

	MOV	R1,R0		;SET UP POINTER FOR DELEET ROUTINE
	TSTB	USTAT(R0)	;FILE MARKED FOR DELETION?
	BMI	DELN03		;YES--TELL HIM IT'S NOT THERE
	BEQ	.+4		;IT'S NOT A UFD, SO DELETION IS POSSIBLE
DELN04:	FIERR	!PRVIOL		;PROTECTION VIOLATION

	MOVB	UPROT(R0),R2	;GET PROTECTION CODE
	MOV	R4,R1		;COPY R4 SO AS NOT TO DESTROY IT
	ADD	#FQPPN1,R1	;POINT TO PPN IN FIRQB
	TST	(R1)		;IS IT THIS USER'S OWN FILE?
	BEQ	DELN02		;YES-USE OWNER PROTECTION BITS
	CMP	(R1)+,@#FIUSER	;MAYBE HE'S BEING CLEVER?
	BEQ	DELN02		;IT'S STILL HIS OWN
	ROR	R2		;NO-IS IT HIS GROUP'S
	ROR	R2		;ASSUME IT IS...
	CMPB	-(R1),@#FIUSER+1;SEE IF ASSUMPTION IS GOOD
	BEQ	DELN02		;IT IS...
	ROR	R2		;IT'S NOT---HE'S AN OUTSIDER
	ROR	R2		;SO USE OUTSIDER BITS
DELN02:	BIT	#2,R2		;IS WRITE PROTECT ASSERTED?
	BNE	DELN04		;IT'S PROTECTED AGAINST WRITING
	TST	UACNT(R0)	;IS ANYBODY LOOKING AT FILE NOW?
	BEQ	DELN07		;NO, SO MAKE IT GO AWAY
	BIS	#200,USTAT(R0)	;MARK THE FILE FOR DELETION
	MOV	SP,@#FIBSTA	;AND NOT ALTERED CONTENTS OF BUFFER
DELN06:	RTS	PC		;MAKE FILE GO AWAY WHEN CLOSED

DELN07:	JMP	@#DELEET	;OFF TO DO DELEETING
;ROUTINE TO HANDLE THE "USAVE" COMMAND.  IF THE USER SAYS "UNSAVE FOO"
;THEN FIRST WE DELETE FOO.BAS, AND THEN FOO.BAC.  IF THE .BAS FILE
;ISN'T THERE, WE DON'T GET TO TRY THE .BAC FILE

UNSF00:	TST	FQEXT(R4)		;IS THE EXTENSION SPECIFIED?
	BNE	DELNAM			;YES, SO IT'S JUST A DELETE BY NAME
	MOV	#R50BAS,FQEXT(R4)	;SET UP .BAS EXTENSION
	JSR	PC,DELN00		;AND DELETE IT IF WE CAN
	MOV	#R50BAC,FQEXT(R4)	;NOW TRY FOR THE .BAC FILE
	BR	DELNAM			;SINCE WE OBVIOUSLY GOT THE .BAS FILE

;ROUTINE TO LOG A USER IN
;WE ASSUME HE IS ALREADY LOGGED IN UNDER [0,0]
;AND THAT WE ONLY WANT TO VALIDATE HIS
;ACCOUNT AND PASSWORD.
;IF THE LOGIN IS SUCCESSFUL, "JFHIBY" IS CLEARED
;IN THE USER'S JOB FLAGS.

LOGIN:	MOV	@#FIJBDA,R1		;MAKE SURE HE'S NOT LOGGED IN NOW
	TST	JDPPN(R1)		;HIS PPN SHOULD BE 0
	BEQ	.+4			;IT IS....
	FIERR	!BADFUO			;BLOW THE WHISTLE ON HIM

	MOV	R4,R1			;COPY FIRQB ADDRESS
	ADD	#FQPPN1,R1		;POINT TO OWNER [1,1] PPN
	MOV	#401,(R1)		;MAKE SURE IT'S  [1,1]
	JSR	R5,@#DIRSIR		;GO SEARCH FOR PASSWORD IN MFD
	+	3			;PPN + 4 CHAR PASSWORD
	BCS	LOGI01			;NOT THERE - BOO HISS!
	MOV	@#FIJBDA,R3		;GET ADDRESS OF JOB DATA BLOCK
	MOV	FQNAM1(R4),JDPPN(R3)	;PROJ-PROG # TO J.D. BLOCK
	MOV	UAR(R1),JDUFD(R3)	;GET UFD START BLOCK
	BIC	#JFHIBY+JFNOPR,JDFLG(R3);CLEAR "HELLO-BYE" FLAG
	RTS	PC

LOGI01:	FIERR+	NOSUCH			;CANT FIND THAT ONE
;ROUTINE TO HANDLE NON-RESIDENT UUO'S
;WE MOVE THE USER'S STRING INTO THE FIRQB, UNLOCK THE JOB, AND
;DISPATCH THE THE APPROPRIATE FIP ROUTINES IF THE UUO IS VALLID.

UUOF:	MOVB	@#FIJOB,R0	;GET THE JOB #
	JSR	PC,@#UNLOCK	;IN CASE WE HIT ANY SNAGS LATER
	MOV	4(R4),R1	;RECOVER USER'S R1 FROM JEFF
	MOV	LENGTH(R1),R3	;AND GET STRING LENGTH FROM HEADER
	CMP	R3,#28.		;ROOM TO COPY ENTIRE STRING IN FIRQB?
	BLOS	UUOF1		;YES--SO LEAVE LENGTH ALONE
	MOV	#28.,R3		;NO--JUST COPY FIRST 28. BYTES. TOUGH!
UUOF1:	ADD	PNTR(R1),R1	;POINT TO STRING IN USER AREA
	MOV	R4,R2		;WE NEED R4 FOR FIP REENTRY
	ADD	#FQFUN,R2	;POINT TO FUNCTION BYTE
	INC	R1		;SKIP MAJOR FUNCTION BYTE (UUOFIP)
	MOVB	(R1)+,R0	;GET SUBFUNCTION BYTE
	CMP	R0,#UUOFMX	;IS IT WITHIN RANGE?
	BLOS	.+4		;IF SO, GOOD
	FIERR	!BADFUO		;ILLEGAL UUO AT USER XXXX

	MOVB	UUOFTB(R0),(R2)+;TRANSLATE TO FIP FUNCTION
UUOF2:	MOVB	(R1)+,(R2)+	;COPY REST OF STRING
	SOB	R3,UUOF2	;INTO THE FIRQB
	JMP	@#FIP04		;AND NOW IT LOOKS LIKE REGULAR FIP CALL

UUOFTA:	.BYTE	LINFQ		;LOGIN UUO
	.BYTE	BYEFQ		;LOGOUT UUO
	.BYTE	PASFQ		;CREATE USER ACCOUNT
	.BYTE	DLUFQ		;DELETE USER ACCOUNT (& FILES)
	.BYTE	DIRFQ		;INDEX DIRECTORY LOOKUP
	.BYTE	RENFQ		;RENAME
	.BYTE	DLNFQ		;DELETE BY NAME
	.BYTE	ERRFQ		;GET ERROR CODE
	.BYTE	ASSFQ		;ASSIGN
	.BYTE	DEAFQ		;DEASSIGN
	.BYTE	DALFQ		;DEASSIGN ALL
	.BYTE	RADFQ		;READ ACCOUNTING
	.BYTE	WADFQ		;WRITE ACCOUNTING
	.EVEN			;FOR THE SAKE OF A CLEAN ASSEMBLY
UUOFMX	=	.-UUOFTA-1	;HIGHEST FIP UUO #

UUOFTB	=UUOFTA-DIRECT+FIPBUF	;RELOCATED TABLE ORIGIN
;SUPPLY AN ERROR MESSAGE FROM THE ERROR "FILE"
;THE ERROR FILE IS A SERIES OF CONTIGUOUS SEGMENTS
;BEGINNING WITH SEGER0 AND CONTINUING AS NECESSARY.
;THERE ARE 16. MESSAGES OF 32. BYTES EACH IN EACH
;ERROR SEGMENT.  ONLY THE FIRST 27. BYTES ARE AVAILABLE
;CALL WITH ERROR MESSAGE FIRQB, WITH THE ERROR CODE IN FQERNO:

FQERNO	=4			;POSITION OF ERROR CODE IN FIRQB

ERRFIL:	MOV	FQERNO(R4),R2	;GET ERROR CODE
	MOV	R2,R1		;GET SET TO DIVIDE BY 16.
	BIC	#-17-1,R1	;REMAINDER FROM DIVISION
	ASR	R2		;NOW DIVIDE
	ASR	R2		;BY 16.
	ASR	R2		;TO FIGURE OUT
	ASR	R2		;WHICH ERROR SEGMENT WE WANT
	ADD	#SEGER0,R2	;THAT'S THE ONE
	JSR	PC,@#READ	;SO GET IT IN
	ASL	R1		;NOW FIGURE INDEX INTO BUFFER
	ASL	R1		;BY MULTIPLYING 
	ASL	R1		;BY 32.
	ASL	R1		;ISN'T THIS
	ASL	R1		;JUST AWFUL??
	ADD	#FIBUF,R1	;NOW WE'VE GOT IT
	CMP	(R4)+,(R4)+	;SKIP FIRST TWO WORDS OF FIRQB
	MOV	#14.,R0		;COPY 14. WORDS (=28.BYTES)
ERRF01:	MOV	(R1)+,(R4)+	;ONE WORD AT A TIME
	SOB	R0,ERRF01	;CONTINUE
	CLRB	-(R4)		;MAKE SURE 0 BYTE TERMINATES MESSAGE
	RTS	PC		;AND BACK TO USER


;ROUTINE TO SEE IF THE SAVE COMMAND A USER HAS ISSUED IS LEGAL
;IF DEVICE <>DSK OR "DSK:FILE.EXT" DOES NOT EXIST THEN IOSTS=0
;	ELSE IOSTS=NOSUCH

SAVOK:	MOV	FQDEV(R4),R0	;NULL DEVICE IMPLIES DISK
	BEQ	SAVOK1		;IMPLIED...IS FILE THERE?
	CMP	R0,#R50DSK	;DSK BY NAME?
	BEQ	SAVOK1		;YES--LOOK FOR FILE
SAVOK2:	RTS	PC		;SAVE IS OK

SAVOK1:	MOV	R4,R1		;SET UP DIRECTORY SEARCH CALL
	ADD	#6,R1		;POINT TO FQPPN IN FIRQB
	JSR	R5,@#DIRSIR	;AND LOOK AROUND
	+	3		;THREE WORD ENTRIES
	BCS	SAVOK2		;NOT FOUND, SO OK
	FIERR	!NOSUCH		;GIVE HIM NOSUCH ERROR SINCE IT'S THERE

DLUF	=SAVOK2
RADF	=SAVOK2
WADF	=SAVOK2
.SIZE4	=.-DIRECT
;ROUTINE TO CLOSE A FILE OR DEVICE.  THE FIRQB POINTER IS IN R4 ON CALL
;IF ACCESS COUNT GOES TO 0 AND FILE IS MARKED FOR DELETION, IT 
;GOES AWAY, AND CLOSE RETURNS WITH "N"=1.  IF A DEVICE IS CLOSED, AND ITS
;INIT COUNT GOES TO 0 AND IT IS NOT ASSIGNED, IT IS RETURNED TO THE POOL
;ON RETURN, R3 POINTS TO THE IO BLOCK SLOT FOR THIS FILE

CLOSE:	JSR	PC,@#FQTOFC	;GET FCB ADDRESS IN R5
	BEQ	CLOS02		;IOB SLOT ADDRESS IN R3
	TSTB	FQFIL(R4)	;IS HE TRYING TO CLOSE CHANNEL 0?
	BEQ	CLOS02		;YES--DON'T LET HIM
	MOV	R5,R1		;JUSR IN CASE ITS A DDB ADDRESS
	MOVB	(R5),R0		;GET HANDLER INDEX FROM DDB/FCB
	ADD	R0,PC		;AND BRANCH ACCORDINGLY
	BR	CLOS03		;DSK--UPDATE ACCESS COUNT, RETURN FCB
	BR	CLOS04		;TTY--FLUSH INPUT BUFFER
	BR	CLOS05		;DTA
	BR	CLOS06		;LPT--FEED THE FORM
	BR	CLOS12		;PTR--FLUSH CHAIN BUFFER
	BR	CLOS10		;PTP--PUNCH A BIT OF TRAILER

CLOS03:	JSR	PC,@#GETNAM	;GET NAME BLOCK IN CORE
	CLR	-(SP)		;"DELETED FLAG" = 0
	MOV	SP,@#FIBSTA	;FORCE BUFFER OUT
	DEC	UACNT(R0)	;BUMP ACCESS COUNT
	BNE	CLOS01		;IF <>0, DON'T EVER DELETE
	TSTB	USTAT(R0)	;SHOULD WE DELETE IT?
	BPL	CLOS01		;ONLY IF THE "DELETE" BIT = 1
	JSR	PC,@#DELEET	;IT WAS..., BYE, BYE
	COM	(SP)		;"DELETE FLAG" = -1
CLOS01:	CLR	(R3)		;CLEAR THE SLOT
	MOV	R4,-(SP)	;SAVE R4
	MOV	R5,R4		;FCB ADDRESS TO R4
	BUFFER,	RETSML		;RETURN THE FCB
	MOV	(SP)+,R4	;RESTORE R4
	TST	(SP)+		;POP THE "DELETE" FLAG
CLOS02:	RTS	PC		;AND RETURN
CLOS12:	BIC	#PTRV,(R1)	;CLEAR OVERFLOW BIT JUST IN CASE
CLOS04:	MOV	R3,-(SP)	;SAVE POINTER TO I/O SLOT
	JSR	R5,@#CLRBUF	;RETURN ANY FREE CORE BUFFERS
	+	TTI+4		;STILL REMAINING IN INPUT CHAIN
CLOS09:	MOV	(SP)+,R3	;RESTORE  R3
CLOS05:	CLR	(R3)		;REMOVE POINTER TO DDB IN IO BLOCK
	DEC	DDCNT(R5)	;REDUCE INIT COUNT
	BNE	CLOS07		;IF NON-ZERO, OR ASSIGN BIT IS ON, HANG ON
CLOS08:	MOV	@#FIJBDA,R2	;GET ADDRESS OF JOB DATA BLOCK
	MOV	DDTIME(R5),R4	;GET TIME DEVICE WAS ASSIGNED
	SUB	@#TIME,R4	;LESS TIME IT IS NOW
	BPL	.+6		;WAS IT ASSIGNED YESTERDAY?
	ADD	#1440.,R4	;YES, SO FUDGE FOR NEGATIVE TIME
	ADD	R4,JDDEV(R2)	;ACCUMULATE INTO JOB'S DEVICE TIME
	CLRB	DDJBNO(R5)	;REMOVE HIS JOB # FROM DDB
CLOS07:	RTS	PC		;AND RETURN

CLOS06:	BIC	#LPTOK,(R1)	;CLEAR HUNG FLAG IN CASE
	MOV	R3,-(SP)	;OUTPUT A FORM FEED FOR LPT
	MOV	#14,R2		;ASCII FORMFEED
	JSR	PC,@#LPTS10	;BUFFER CHARACTER IN LPT BUFFER
	JSR	PC,@#LPTS10	;FEED TWO FORMS
	BISB	(PC),@#LPS	;IF LPT WASN'T GOING, IT IS NOW
	BR	CLOS09		;RESTORE R3 AND EXIT

CLOS10:	MOV	R3,-(SP)	;SAVE R3
	MOV	#120.,R0	;A FOOT WILL DO
	CLR	R2		;NULL CHARACTER
CLOS11:	JSR	R5,@#STORE	;STORE IN PTP BUFFER
	+	PTPFP		;DDB OFFSET
	SOB	R0,CLOS11	;CONTINUE AND IGNORE FULL BUFFER
	BIS	#100,@#PPS	;JUST IN CASE IT WASN'T GOING BEFORE
	BR	CLOS09		;THE REST IS COMMON
;ROUTINE TO EXPLICITLY DELETE A FILE 
;WE ONLY DO IT IF THE USER IS WRITE ENABLED ON THE FILE
;AND THEN ONLY IF NOBODY IS READING IT NOW
;IF THEY ARE, WE JUST MARK FILE FOR DELETION WHEN LAST USER
;CLOSES IT

;R4 CONTAINS  POINTER TO FIRQB FOR  FILE

DELETE:	JSR	PC,@#FQTOFC	;GET FCB ADDRESS
	BNE	.+4		;IF NONE, WE WON'T DELETE IT
	FIERR+	NOTOPN		;TILT!

	BIT	#2000,(R5)	;WRITE ENABLED?
	BEQ	.+4		;IF NOT, DON'T DELETE
	FIERR+	PRVIOL		;TILT!

	JSR	PC,CLOSE	;CLOSE THE FILE TO RETURN FCB
	BMI	DELE03		;CLOSING FORCED DELETION
	TSTB	UACNT(R0)	;ANYBODY LOOKING?
	BNE	DELE01		;IF SO, JUST MARK FOR DELETION LATER
	JMP	@#DELEET	;IF NOT, BYE, BYE

DELE01:	BISB	#200,USTAT(R0)	;TURN ON DELETION BIT
DELE03:	RTS	PC		;RETURN WITH DOOM SEALED


;ROUTINE TO DO AN IO RESET FOR A USER-----------------------------------
;WE CLOSE ALL CHANNELS EXCEPT THE TTY OPEN ON #0
;ANY DEVICE ASSIGNMENTS ARE UNAFFECTED

RESET:	MOV	#36,-(SP)	;WE CLOSE THEM FROM #15 TO #1
RESE01:	MOVB	(SP),FQFIL(R4)	;SET THE FILE # IN FIRQB SLOT
	JSR	PC,CLOSE	;CLOSE THE FILE
	SUB	#2,(SP)		;NEXT LOWER NUMBERED FILE
	BGT	RESE01		;CONTINUE UNTIL ALL DONE
	TST	(SP)+		;CLEAR EXHAUSTED COUNT FROM STACK
	RTS	PC		;RETURN


;ROUTINE TO DEASSIGN ALL A USER'S DEVICES (EXCEPT TTY)

DEALL:	MOV	#DEVTBL,R1	;NOW DEASSIGN EVERYTHING
DEALL1:	MOV	(R1)+,R5	;BY PUSHING ALL DDB'S THRU
	JSR	PC,RLSE00	;SINCE INVALID DEASSIGN'S ARE IGNORED
	CMP	R1,#JOBTBL	;END OF DEVTBL?
	BLO	DEALL1		;NOT YET
	RTS	PC		;YES, RETURN

;ROUTINE TO DO THE DEAS BOOKEEPING---------------
RLSE00:	CMPB	DDJBNO(R5),@#FIJOB	;THIS JOB OWNS DEVICE?
	BNE	RLSE01			;NO, SO DON'T DO ANYTHING
	BIC	#DDASN,DDCNT(R5)	;YES,CLEAR ASSIGN BIT IN DDB
	BEQ	CLOS08			;NOT INIT'ED, SO DO ACCOUNTING
RLSE01:	RTS	PC			;STILL OPEN, SO DON'T " "
;LOG A USER OUT--CLOSE HIS FILES, UPDATE ACCOUNTING INFO, DEASSIGN ALL

LOGOUT:	MOV	@#FIJBDA,R0	;GET HIS JOB PDATA ADDRESS
	BIT	#JFHIBY,JDFLG(R0) ;DID HE REALLY TYPE "BYE"?
	BNE	.+4		;YES, HE DID
	FIERR	!BADFUO		;HE'S MEDDLING---GIVE HIM A BAD UUO!

	JSR	PC,RESET	;CLOSE ALL HIS FILES EXCEPT TTY
	MOV	@#FIJBDA,R3	;GET ADDRESS OF JOB DATA AREA
	MOV	R3,R5		;LEAVE IN R3 FOR ALL ETERNITY
	MOV	@(R5)+,R5	;GET TTY DDB ADDRESS
	CLR	DDCNT(R5)	;CLEAR STATUS SO DEASSIGN SUCCEEDS
	JSR	PC,RLSE00	;AND DEASSIGN IT
	SUB	R4,JDDEV(R2)	;BUT IT'S CONNECT, NOT DEVICE TIME
	MOV	R4,-(SP)	;SO SAVE ON STACK & ENTER LATER
	JSR	PC,DEALL	;RETURN ALL THE OTHER DEVICES
	MOV	JDPPN(R3),-(SP)	;FIND HIS MFD ENTRY
	MOV	#401,-(SP)	;BY SEARCHING MFD FOR HIS PPN
	MOV	SP,R1		;SEARCH PARAMETERS ON STACK
	JSR	R5,@#DIRSIR	;CALL SEARCH
	+	1		;ONE WORD ONLY
	CMP	(SP)+,(SP)+	;POP GARBAGE OFF STACK
	MOV	UAA(R1),R0	;MFD ADDRESS OF ACCOUNTING BLOCK
	JSR	PC,@#GETLNK	;GET ACCOUNTING BLOCK
	TST	(R0)+		;SKIP OVER MARKER
	MOV	R3,R1		;ADDRESS OF JOB DATA BLOCK
	ADD	#JDCPU,R1	;POINT TO CPU TIME USED
	ADD	(R1)+,(R0)+	;ACCUMULATE CPU TIME INTO MFD
	ADD	(SP)+,(R0)+	;ACCUMULATE CONNECT TIME INTO MFD
	ADD	(R1)+,(R0)+	;DEVICE TIME USED
	ADD	(R1)+,(R0)+	;KCT'S USED
	JSR	PC,@#WRITE	;SAVE UPDATED BUFFER
	MOV	(R3),R4		;GET ADDRESS OF I/O BLOCK
	BUFFER,	RETSML		;AND RETURN IT
	MOV	R3,R4		;GET ADDRESS OF DATA BLOCK
	BUFFER,	RETSML		;AND RETURN IT TOO
	MOVB	@#FIJOB,R0	;PUT JOB INTO PERMANENT WAIT
	JSR	PC,@#CORE	;REMOVE JOB FROM CORTBL IF IT'S THERE
	BMI	LOGO1		;RETURNS MINUS IF NOT FOUND
	DEC	R2		;RETURNS POINTER TO HIGH BYTE IF FOUND
	CLR	(R2)+		;IT'S NOT THERE ANY MORE
	CMPB	R0,(R2)		;NEXT ENTRY TOO?
	BEQ	.-4		;YES--CLEAR IT TOO
LOGO1:	CLR	JBWAIT(R0)	;THAT SHOULD DO IT
	CLR	JBSTAT(R0)	;JUST TO MAKE SURE
	CLR	JOBTBL(R0)	;REMOVE POINTER TO DATA BLOCK
	MOV	@#FIQUE,R4	;GET FIRQB ADDRESS OF THIS REQUEST
	MOV	(R4),@#FIQUE	;ADN UNQUEUE NEXT REQUEST
	BUFFER,	RETSML		;REUTRN FIRQB
	TST	@#FIQUE		;NOW BACK TO FIP CONTROL
	JMP	@#FIEX03	;AND BACK TO FIP
.SIZ10	=.-CLOSE
	.BEGIN	=.
SCDEV	=	1
SCEXT	=	2
SCPR2	=	4
SCPR1	=	10
SCPP2	=	20
SCPP1	=	40
SCR50	=	100
SCNUM	=	200
SCOMA	=	400
SCDLM	=	1000


SCTBL1	=	FIPBUF+SCTB1-SCAN00	;FOR AS WE MOVE
SCTBL2	=	FIPBUF+SCTB2-SCAN00-2	;FOR MOVING TO FIPBUF


SCAN00:
SCTB1:	.BYTE	'$
	.BYTE	':
	.BYTE	'<
	.BYTE	'>
	.BYTE	'[
	.BYTE	']
	.BYTE	',
	.BYTE	'.
	.BYTE	0
	.BYTE	'A
	.BYTE	'Z
	.BYTE	'0
	.BYTE	'9
	.EVEN
SCTB2:
	.WORD	SCAN21-SCAN00+FIPBUF
	.WORD	SCAN22-SCAN00+FIPBUF
	.WORD	SCAN31-SCAN00+FIPBUF
	.WORD	SCAN32-SCAN00+FIPBUF
	.WORD	SCAN25-SCAN00+FIPBUF
	.WORD	SCAN27-SCAN00+FIPBUF
	.WORD	SCAN26-SCAN00+FIPBUF
	.WORD	SCAN24-SCAN00+FIPBUF
SCAN21:	TST	R5		;$ FOUND
	BNE	SCAN40		;BRANCH IF ILLEGAL
	TST	(SP)		;SEE IF ANY PRIOR LETTERS
	BNE	SCAN40		;BRANCH IF TOO LATE
	MOV	#R50DSK,FQDEV(R4);DEVICE=DSK
	MOV	#000402,FQPPN1(R4);PPN=[1,2]
	BIS	#SCDEV!SCPP1!SCPP2,R5	;SET DEVICE AND PPN FOUND
	BR	SCAN41		;RESUME THE SCAN

SCAN22:	BIT	R5,#SCDEV!SCEXT	;:SEEN -- FIRST ONE?
	BNE	SCAN40		;BRANCH IF ILLEGAL STRING
	TST	(SP)
	BNE	SCAN23
	BIS	#SCDEV,R5
	MOV	FQNAM1(R4),FQDEV(R4);MOVE THE
	MOV	FQNAM1+2(R4),FQDEV+2(R4);DEVICE NAME
	CLR	FQNAM1(R4)	;CLEAR THE FILE NAME
	CLR	FQNAM1+2(R4)	;BOTH WORDS OF IT
	BIC	#SCDLM,R5	;CLEAR DELIMITER FLAG
	BR	SCAN02		;RESUME THE SCAN

SCAN24:	BIT	R5,#SCEXT	;.FOUND - THE ONLY ONE?
	BNE	SCAN40		;BRANCH IF ILL-FORMED
	TST	(SP)		;SEE IF ANY LEFT OVER FILE NAME
	BNE	SCAN23		;BRANCH TO CLEAN IT UP
	BIS	#SCEXT,R5	;SHOW . FOUND
	BIC	#SCDLM,R5	;CLEAR THE DELIMITER
	BR	SCAN02		;RESUME THE SCAN

SCAN25:	BIT	R5,#SCPP1	;[ FOUND - ONLY ONE ALLOWED
	BNE	SCAN40		;BRANCH IF ILL FORMED
	TST	(SP)		;SEE IF LEFT OVER ANYTHING
	BNE	SCAN23		;BRANCH TO DO HOUSE KEEPING
	BIS	#SCPP1!SCNUM,R5	;SET INSIDE SWITCHES
	BIC	#SCDLM,R5
SCAN41:	BR	SCAN02

SCAN26:	BIT	R5,#SCOMA	;SEE IF ONLY ONE ,
	BNE	SCAN40		;BRANCH IF ILLEGAL
	MOVB	(SP),FQPPN1+1(R4);STORE PROJECT NUMBER
	BIS	#SCOMA,R5	;SET , FOUND
	CLR	(SP)		;CLEAR NUMBER
	BR	SCAN02		;RESUME THE SCAN

SCAN27:	BIT	R5,#SCPP2	;SEE IF WE'VE SEEN ONE BEFORE
	BNE	SCAN40		;CAN'T HAVE 2 ]
	BIT	R5,#SCPP1	;SEE ABOUT OPENING [
	BEQ	SCAN40		;WE HAVE TO HAVE [
	BIT	R5,#SCOMA	;SEE IF , SEEN BEFORE
	BEQ	SCAN30		;BRANCH IF NOT SEEN
	MOVB	(SP),FQPPN1(R4)	;STORE PROGRAMMER #
	BR	SCAN29

SCAN30:	MOV	(SP),FQPPN1(R4)	;MOVE BOTH TO PPN
SCAN29:	BIS	#SCPP2,R5	;SET ] SEEN
	BR	SCAN33		;RESUME

SCAN31:	BIT	R5,#SCPR1	;SEE IF MORE THAN 1 <
	BNE	SCAN40		;BRANCH IF BAD
	TST	(SP)		;SEE IF BRANCHING STUFF
	BNE	SCAN23		;BRANCH TO FIX IT UP
	BIS	#SCNUM!SCPR1,R5	;GO NUMBERS AND SHOW <
	BR	SCAN02

SCAN32:	BIT	R5,#SCPR2	;SEE IF EXTRA >
	BNE	SCAN40		;BRANCH IF ERROR
	BIT	R5,#SCPR1	;SEE IF WE HAD A <
	BEQ	SCAN40		;BRANCH IF ERROR
	MOVB	(SP),FQPROT+1(R4) ;STORE PROTECTION
	COMB	FQPROT(R4)	;SET PROTECTION CHANGING FLAG
	BIS	#SCPR2,R5	;SHOW A >
SCAN33:	BIC	#SCNUM,R5	;GO TO RAD 50
	CLR	(SP)		;CLEAR UP OUR MESS
	BR	SCAN02		;RESUME SCANNING

SCAN23:	DEC	R2		;SET UP CHARACTER
	INC	R3		;  TO SCAN IT AGAIN
	BR	SCAN16		;FORCE OUT THE REMAINING LETTERS

SCAN20:	SUB	#SCTBL1,R0	;CALCULATE INDEX
	ASL	R0
	JMP	@SCTBL2(R0)	;DISPATCH

SCAN40:	FIERR+NOSUCH		;ITS ILLEGAL
SCAN50:	TST	(SP)		;SEE IF BUSY WORK LEFT
	BNE	SCAN23
	BIT	R5,#SCNUM	;SEE IF STILL INSIDE
	BNE	SCAN40
	CMP	(SP)+,(SP)+	;GET RID OF JUNK ON STACK
	RTS	PC		;AND BACK TO FIP CENTRAL

SCAN:	MOVB	@#FIJOB,R0	;GET THE JOB #
	JSR	PC,@#UNLOCK	;RELEASE CORE TO SCHEDULER
	MOV	6(R4),R2	;GET THE USERS R2 BACK
	MOV	LENGTH(R2),R3	;GET LENGTH OF STRING IN R3
	ADD	PNTR(R2),R2	;R2 POINTS TO THE STRING
	MOV	R4,-(SP)	;SAVE R4 FOR RE-QUEING
	ADD	#6,R4		;GO TO SPECIFICATION WORDS
	MOV	#15,R5		;FIFTEEN WORDS DESCRIBES A FILE
SCAN01:	CLR	(R4)+		;CLEAR A WORD
	SOB	R5,SCAN01	;LOOP IF MORE TO DO
	MOV	(SP)+,R4	;GET THE ORIGINAL FIRQB BACK
	CLR	-(SP)		;MAKE A FOUR (REALLY THREE)
	CLR	-(SP)		;  CHARACTER WORK AREA
	CLR	R5		;CLEAR ALL FLAGS
SCAN02:	DEC	R3		;DECREMENT CHARACTER COUNT
	BLT	SCAN50		;IF ALL GONE THEN FINISH UP
	JSR	PC,@#SKIP	;PASS BADDYS
	MOVB	(R2)+,R1	;GET A CHARACTER
	BIC	#177600,R1	;CLEAR PARITY BIT AND SIDE EFFECT
	BEQ	SCAN02		;IF NULL THEN IGNORE IT
	MOV	#SCTBL1,R0	;GET TABLE OF SPECIAL CHARACTERS
SCAN03:	CMPB	R1,(R0)+	;SEE IF THERE
	BEQ	SCAN20		;BRANCH IF FOUND
	TSTB	(R0)		;SEE IF END OF THE LIST
	BNE	SCAN03		;LOOP IF MORE SPECIAL CHARACTERS
	INC	R0		;GO TO THE NUMBERS AND ALPHAS
	BIT	R5,#SCNUM	;SEE IF NUMBER NEEDED
	BNE	SCAN17		;IGNORE CHARACTERS AFTER FIRST 6
	CMPB	R1,(R0)+	;SEE HOW RELATIVE TO "A"
	BLT	SCAN04		;BRANCH IF UNRECOGNIZED
	CMPB	R1,(R0)+	;SEE ABOUT A "Z"
	BGT	SCAN05		;BRANCH IF IN TROUBLE
	SUB	#56,R1		;100=56+22 IS THE REDUCTION FOR A->Z
SCAN06:	SUB	#22,R1		;22 IS REDUCTION FOR 0->9
	BIT	R5,#SCR50!SCDLM	;SEE IF ANY RADIX 50 ALLOWED
	BNE	SCAN02		;BRANCH IF ALL FULL UP
	TSTB	(SP)		;SEE IF FIRST OF THREE
	BNE	SCAN07		;BRANCH IF ALREADY FILLED
	MOVB	R1,(SP)		;ELSE MOVE IT IN
	BR	SCAN02		;AND RESUME THE SCAN

SCAN12:	MOV	R1,FQNAM1(R4)	;STORE FIRST 3 CHARACTERS
SCAN13:	CLR	(SP)		;CLEAR THE WORK AREA
	CLR	2(SP)		;BOTH PARTS OF IT
	BR	SCAN02
SCAN17:	INC	R0		;SKIP ALPHAS
SCAN04:	INC	R0		;GO TO THE NUMERICS
SCAN05:	CMPB	R1,(R0)+	;SEE ABOUT NUMBERS -- 0
	BLT	SCAN40		;BRANCH IF TOO SMALL
	CMPB	R1,(R0)+	;SEE ABOUT NUMBERS -- 9
	BGT	SCAN40		;BRANCH IF NOT 0 - >9
	BIT	R5,#SCNUM	;SEE IF NUMERIC COLLECTION
	BEQ	SCAN06		;BRANCH IF RADIX 40. NUMBERS
	SUB	#'0,R1		;MAKE INTO BINARY
	ASL	(SP)		;MULTIPLY BY 10.
	ADD	(SP),R1		;SAVE 2*SUM
	ASL	(SP)		;MULTIPLY BY 8.
	ASL	(SP)
	ADD	R1,(SP)		;ADD THE CURRENT DIGIT
	BR	SCAN02		;GO GET MORE


SCAN07:	TSTB	1(SP)		;SEE IF SECOND OF THE SERIES
	BNE	SCAN10		;BRANCH IF THIRD AND TIME TO FILL
	MOVB	R1,1(SP)	;STORE SECOND OF THREE
	BR	SCAN02		;RESUME THE SCAN

SCAN10:	MOVB	R1,2(SP)	;STORE THE THIRD CHARACTER
SCAN16:	MOV	SP,R0		;USE A REGISTER THAT INCREMENTS BY 1
	MOV	#3,-(SP)	;STORE A COUNTER
	CLR	R1		;CLEAR THE WORD TO BE
SCAN11:	CLR	-(SP)		;CLEAR A SLOT FOR THE DIGIT
	MOVB	(R0)+,(SP)	;MOVE BYTE NO SIGN EXTEND
	ASL	R1
	ASL	R1
	ASL	R1		;MULTIPLY BY
	ADD	R1,(SP)
	ASL	R1		;40.  THEN
	ASL	R1
	ADD	(SP)+,R1	;ADD CURRENT DIGIT
	SOB	(SP),SCAN11	;DECREMENT AND BRANCH
	TST	(SP)+		;REMOVE THE COUNTER
	BIT	R5,#SCEXT	;SEE IF NAME OR EXTENSION
	BNE	SCAN14		;BRANCH IF DOT SEEN
	TST	FQNAM1(R4)	;SEE IF FIRST OR SECOND 3
	BEQ	SCAN12		;BRANCH IF FIRST WORD
	MOV	R1,FQNAM1+2(R4)	;STORE SECOND 3 CHARACTERS
SCAN15:	BIS	#SCDLM,R5	;FORCE A DELIMITER
	BR	SCAN13		;RESUME THE SCAN

SCAN14:	MOV	R1,FQNAM1+4(R4)	;STORE THE EXTENSION
	BR	SCAN15		;SET MAYBE TROUBLE BITS

.SIZ11	=.-SCAN00
.LEFT.	=512.-.SIZ11
.	=.BEGIN+512.		;A LITTLE PATCH SPACE ON DISK
;SWAP AREA NON-RESIDENT SEGMENT---------------------------------------
;LOCATIONS OF SAVED USER CSR PARAMETERS ON STACK
SVR6CO	=22
SVR1CO	=SVR6CO+2
SVSPDA	=SVR1CO+2
SVSPTA	=SVSPDA+2
SVSCTH	=SVSPTA+2
SVR1RI	=SVSCTH+2
SVR5RI	=SVR1RI+2
SVR1	=42
HEINZ:
CATS00:	MOV	14(R4),R4	;JOBORG--PREPARE TO ZERO USER'S AREA
	BIC	#CALER2,(R4)	;CLEAR UNRECOVERABLE STORAGE ERROR
	MOV	@#FIJBDA,R5	;JOB DATA BLOCK
	MOV	JDSP(R5),R5	;SAVED USER PARAMETER BASE
	ADD	R4,R5		;MAKE ABS
	MOV	R4,R2		;SAVE JOBORG IN R4
	MOV	R2,R3		;NEED A CUR AND END POINTER
	ADD	#R6SORG,R2	;BUT ONLY FROM HERE UP
	ADD	#CAILEN,R3	;LENGTH OF INITIAL CORE ALLOCATION
CAT4:	CLR	(R2)+		;CLEAR ONE WORD
	CMP	R2,R3		;SEE IF WE'RE DONE
	BNE	CAT4		;NOT YET
	MOV	#CACSR3-CATS00+FIPBUF,R0	;RELOCATED TABLE
	MOV	R5,R1		;POINTER TO CSR
	ADD	#SVSCTH,R1	;ON USER SP STACK
	MOV	(R0)+,-(R1)	;SPTA
	MOV	(R0)+,-(R1)	;SPDA
	MOV	(R0)+,-(R1)	;R1CORG
	MOV	(R0)+,-(R1)	;R6CORG
	MOV	#ENDNZD-BEGHDR,R3	;SET UP DATA AREA***************
	ASR	R3			;#WORDS=#BYTES/2
	MOV	R4,R1			;USE JOBORG TO
	ADD	SVSPDA(R5),R1		;MAKE A SPDA POINTER
	SUB	#BEGPDA-BEGHDR,R1	;START STORING IN HEADER AREA
	MOV	#BEGHDR-CATS00+FIPBUF,R2;START OF DATA AREA
CAT2:	MOV	(R2)+,(R1)+
	SOB	R3,CAT2			;LOOP TILL DONE
	MOV	#ENDPTA-BEGPTA,R3	;NOW DO TEXT AREA********
	ASR	R3			;# WORDS TO MOVE= # BYTES/2
	MOV	R4,R1			;USE JOBORG
	ADD	SVSPTA(R5),R1		;TO MAKE A SPTA POINTER
	MOV	#BEGPTA-CATS00+FIPBUF,R2;START OF PROGRAM AREA
CAT1:	MOV	(R2)+,(R1)+
	SOB	R3,CAT1
	MOVB	@#FIJOB,R0		;PREPARE TO UNLOCK
	JMP	@#UNLOCK		;THE USER FROM CORE
CACSR3:	TGSORG				;SPTA-----INITIAL RELATIVE VERSIONS
	PDAORG				;SPDA
	R1SORG				;R1CORG
	R6SORG				;R6CORG
;INITIAL USER AREA SETUP PARAMETERS

CAILEN	=10000		;INITIAL USER AREA LENGTH IN BYTES
CAIBLK	=2		;AND IN 1K BLOCKS AS ALLOCATED BY .CORE
R6SORG	=1000		;RELATIVE BEGINNING OF THE USER R6 STACK
R6SSEG	=1		;USER STACK SIZE IN DISK SEGMENTS
R1SORG	=1400		;RELATIVE BEGINNING OF THE USER R1 STACK
PDAORG	=2000		;PROGRAM DATA RELATIVE BEGINNING
TGSORG	=7400		;PROGRAM TEXT RELATIVE BEGINNING
TAGSIZ	=400		;LENGTH OF INITIAL TAG (STATEMENT HEADER) AREA

;-------------------------------------------------------------------
;CONVENIENT MACRO FOR DEFINING RELATIVE SYMBOLS
;SYMBOLS WHICH BEGIN WITH $ ARE RELATIVE TO THE BEGINNING OF THEIR AREA
;PROGRAM TEXT AREA -- REFERRED TO RELATIVE TO SPTA 
	.MACR	$	Q14159,R27182
		Q14159=.-BEGPTA
		R27182
	.ENDM
BEGPTA:
HEADPT:	+	0			;LOCATION OF FIRST STATEMENT HEADER
	ENDPTA-HEADPT			;POSITIVE LIMIT ASSEMBLED STUFF
	+	0			;NEG LIMIT ASSEMBLED STUFF (NONE)

$ PROPTR,	ENDPTA-BEGPTA		;PLUDYN
$ TAGPTR,	+0			;LAST USED WORD IN STATEMENT HEADER AREA
$ PROLIM,	CAILEN-TGSORG		;PLULIM
$ TAGLIM,	-TAGSIZ			;LIMIT OF STATEMENT HEADER AREA
ENDPTA:

	.MACR	$	Q14159,R27182
			Q14159=.-BEGPDA
			R27182
	.ENDM

	.MACR	$B	X,Y
			X=.-BEGPDA
			.BYTE	Y
	.ENDM

;-----------------------------------------------------
;THE FOLLOWING ARE EDITOR VARIABLES WHICH ARE LEFT
;UNCHANGED THROUGH IMAGE TRANSFERS TO AND FROM .BAC FILES
;(EDFLAG IS REFERRED TO AS @JOBORG; EDNAME IS REFERRED TO REL JOBORG.)
EDFLAG	=0		;FLAGS FOR ED'S USE
EDNAME	=2		;REST OF AREA IS SHAPED LIKE A FIRQB
;------------------------------------------------------------
;PROGRAM DATA AREA -- REFERRED TO RELATIVE TO SPDA
BEGHDR:					;DEFINES THE CURRENT POINTER IN HEADER
PICON	=177764
	.WORD	166520			;CONSTANT PI
	.WORD	62207
	.WORD	100002

ONECON	=177772
	.WORD	0			;FLOATING ONE
	.WORD	40000
	.WORD	100001

BEGPDA:					;DEFINES THE BEGINNING OF THE PDA
$ PDA,	DUMSTR				;POINTER TO LAST AND DUMMY STRING

;CORE ALLOCATION PARAMETERS
$ PSD,	ENDSTT-BEGPDA
$ MSD,	+0
$ NEXSTR,	ENDSTT-BEGPDA		;NEXT AVAILABLE WORD IN THE STRING AREA
PDD	=	NEXSTR			;DUPLICATE NAME
$ NEXFRE,	BEGHDR-BEGPDA		;POINTS TO LAST CELL USED IN STRING HEADER AREA
MDD	=	NEXFRE			;DUPLICATE NAME
$ STRLIM,	TGSORG-TAGSIZ-PDAORG	;STRING LIMIT -- LEAVE ROOM FOR A FEW TAGS
PLD	=	STRLIM			;DUPLICATE NAME
$ SPCLIM,	R1SORG-PDAORG		;STRING HEADER LIMIT WITH 24 WORDS SLOP
MLD	=	SPCLIM			;DUPLICATE NAME
$ ARYPTR,	BASE			;FIRST I/O ARRAY HEADER ITEM
;DO NOT DISTURB CELL ORDER BACK TO BEGPDA

$ TLMIND,	BEGHDR-BEGPDA		;OLD VALUE OF STR HDR PTR, RESTRD AFTER ERROR
$ BASSEG,	+177777			;SEGMENT IN BUFFER CURRENTLY
$ STAT,		+BLINEF			;LEX ANALYZER STATUS FLAGS
;STRINGS-------------------------------------------------
;STRING VERSION OF $LOGIN

$ EDLGIN,	+0			;NO LINK
	+6				;TEXT REL .-2
	+6				;LENGTH IN CHARS
	.ASCII	/$LOGIN/
	.EVEN

;STRING VERSION OF $LOGOUT

$ EDLGOT,	+0
	+6
	+7
	.ASCII	/$LOGOUT/
	.EVEN

;DUMMY FILENAME FOR USER WHO FORGETS TO PROVIDE IT

$ EDDUMM,	0			;NO LINK
	6				;POINTER RELATIVE TO START
	6				;LENGTH
	.ASCII	/NONAME/
	.EVEN
$ CURRIO,	0			;CURRENT IO POINTER
$ DATHDR,	0			;DATA STATEMENT HEADER
$ DATCNT,	0			;DATA STATEMENT RESIDUAL COUNT
$ DATPTR,	0			;DATA STATEMENT POINTER
$ RNDM,		0			;RANDOM NUMBER STORAGE BIN


;PERMANENT VARIABLE AREA--------------------------------------------
;CORE ALLOCATOR VARIABLES-GO IN PDA
;"NOMINALS" ARE FREE SPACE AMOUNTS GUARANTEED BY CA
;
$ R1SNOM,	+100			;NOMINAL FOR R1 STACK
$ TAGNOM,	+626.			;NOMINAL FOR STATEMENT HEADERS
$ PRONOM,	+564.			;NOMINAL FOR STATEMENT-PUSH POP
$ HDRNOM,	+342.			;NOMINAL FOR STRING HEADERS
$ STRNOW,	+0			;MODIFIED BY CA
$ STRNOM,	+1000			;NOMINAL FOR STRINGS
;DO NOT DISTURB CELL ORDER BACK TO R1SNOM
;
;
$ SUMNOM,	+0			;SUM OF ALL NOMINALS
$ NSTRNM,	+0			;SUM OF ALL BUT STRING
;
$ CAAREA,	+0			;AREA NEEDED ON CORE ALLOX CALL
$ CACORE,	+0			;CORE NEEDED
BASE	=	.-BEGPDA	;LENGTH OF BASE AREA
SLOTM1:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	LINBUF-SLOTM1	;POINTER TO THE BUFFER
	.WORD	LINLEN		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	LINBUF-SLOTM1	;CURRENT LOCATION
	.BYTE	-2		;SLOT NUMBER
ERRVAL	=	.-BEGPDA	;ERROR VALUE FOR ON ERRROR GOTO SUBS
	.BYTE	0		;FLAG BYTE
OEGTLN	=	.-BEGPDA	;ON ERROR GOTO LINE NUMBER
	.WORD	0		;CURRENT POSITION
WAITTM	=	.-BEGPDA	;WAIT TIME FOR TTY I/O
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT0:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	TTYBUF-SLOT0	;POINTER TO THE BUFFER
	.WORD	TTYLEN		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	TTYBUF-SLOT0	;CURRENT LOCATION
	.BYTE	0		;SLOT NUMBER
	.BYTE	FORCE		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	70.		;MAXIMUM LINE LENGTH

SLOT1:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	2		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT2:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	4		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT3:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	6		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT4:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	10		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT5:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	12		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT6:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	14		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT7:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	16		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT8:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	20		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH
SLOT9:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	22		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT10:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	24		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT11:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	26		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT12:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	30		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT13:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	32		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH
SLOT14:	.WORD	IOLEN		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	34		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH

SLOT15:	.WORD	0		;LINK TO THE NEXT
	.WORD	0		;POINTER TO THE BUFFER
	.WORD	0		;LENGTH OF THE BUFFER
	.WORD	0		;BYTE COUNT
	.WORD	0		;CURRENT LOCATION
	.BYTE	36		;SLOT NUMBER
	.BYTE	0		;FLAG BYTE
	.WORD	0		;CURRENT POSITION
	.WORD	0		;MAXIMUM LINE LENGTH
;
	.EVEN
.SIZE.	=.-CATS00		;HOW BIG WE ARE...

ENDNZD:				;END OF NON-ZERO INITIAL PDA

;REST OF STUFF IS SUPPOSSED TO BE 0 AND IS NOT MOVED INTO USER AREA BY CATSUP

$ PDAODD,	+0		;LOW BIT STR PTR DURING GARB COL
$ PTAODD,	+0		;LOW BIT PRO PTR DURING GARB COL
$ RESLOC,	+0		;SAVE SCTH FOR ERRORS
;BASGET AND BASPUT VARIABLES----------------------------------
;
$ BASBUF,	.=.+1000		;TMP FILE BUFFER
$ BASCUR,	+0			;NEXT ADDRESS TO BE WRITTEN IN TMP FILE
$ BASMOD,	+0			;IF SET: WRITE OUT BEFORE OVERLAYING
$ TMPFCB,	+0			;FILE CONTROL BLOCK LOCATION WHEN FILE OPEN
;
$ GETAGV,	+0			;ANSWER CELL FOR GETAG SUBRS
;***********************************************************************
;LEXICAL ANALYZER TABLE, BUFFER, & DATA ITEMS
;***********************************************************************

;THIS TABLE DISPATCHES THE VARIABLE SYMBOL TABLE. THE SELF-RELATIVE
;ADDRESS OF THE FIRST ENTRY BEGINNING WITH, SAY, X IS LOCATED AT VARTAB+2*('X-'A)
;(FOR PURPOSES OF LOOKING UP A FUNCTION NAME, THE FN-PREFIX IS IGNORED)
;AN ENTRY HAS THE FORM (IN DESCENDING LOCATIONS):
;	SELF-RELATIVE ADDRESS OF NEXT ENTRY BEGINNING WITH X
;	DIGIT (IF ANY) FOLLOWING X IN NAME (0NE BYTE)
;	FIRST TOKEN SUBTABLE ENTRY FOR THAT NAME
;ASSOCIATED WITH EACH NAME IS A 1-BYTE TOKEN WHICH (AS DESCRIBED ELSEWHERE)
;GIVES THE TYPE INFORMATION  (FUNCTION,INTEGER, STRING, ARRAY, ETC)
;ABOUT THE VARIABLE. ASSOCIATED WITH EACH NAME MAY BE VARIABLES OF SEVERAL
;DIFFERENT TYPES, AND EACH TYPE IS REPRESENTED BY ITS OWN ENTRY IN A SUBTABLE ASSOCIATED
;WITH THE VARIABLE NAME. EACH SUBTABLE ENTRY IS OF THE FORM (IN DESCENDING ORDER):
;	1-BYTE TOKEN
;	1-BYTE TOKEN AGAIN (IF TOKEN NOT AT EVEN LOCATION)
;	1-WORD SELF-REL ADDRESS OF NEXT SUBTABLE ENT
;	ANY NUMBER OF VALUE WORDS
;ANY TIME THE POINTER TO A TABLE OR SUBTABLE ENTRY IS 0, THAT ENTRY DOES NOT EXIST

$ VARTAB,	+0		;A THRU Z
	.REPT	25.
	.WORD	0
	.ENDR
;SMALL DATA ITEMS

$ CLB,		+0		;CURRENT BEG LEX BUF
$ TOKE,		+0		;TOKEN (LOWER BYTE ONLY)
$ TOKA,		+0		;ADDRESS PORTION OF TOKEN
$ UNQUOT,	+0		;HOLDS UNQUOTE CHAR TO CLR QUOTF
$ FIRHED,	+0		;ADDR OF LINK IN FIRSP HEADER

;***********************************************************************
;END OF LEXICAL ANALYZER STUFF
;***********************************************************************
;***********************************************************************
;

$ CFLG,		+0		;FLAG WORD FOR MODIFIER ROUTINES
$ NEXDRO,	+0		;DROP THRU "NEXT" STATEMENT IF RPTERM FLAG ON
$ RPTERM,	+0		;TREAT "NEXT" STATEMENT AS TERMINAL
$ MATBLK,	+0		;USED BY SOME OF THE STRING PUSHPOPS
	.WORD	0,0
;TL DATA (IN USER SWAP AREA)
$ TLPCOU,	+0	;PARENTHESIS DEPTH COUNTER
$ TLFNBK,	+0	;TEMP. LOC. FOR FUNCTION BLOCK - DODEF
$ TLFNAT,	+0	;PICTURE WORD ACC. -DODEF
$ PRPMOD,	+0	;TEMP. LOC. FOR SAVED PMODE  VALUE
$ TLBIFF,	+0	;BUILT-IN (1) VS USER-DEF (0) FCN FLAG
$ PTOKA,	+0	;WORD PART OF PREV.TOKEN INF.
$ TLLINO,	+0	;LINE NO. OF CURR. STAT.
$ CPREC,	+0	;CURR. PREC. VALUE
$ PRPREC,	+0	;PREV. PREC. VALUE
$ PMODE,	+0	; CURRENT PMODE VALUE
$ NARGS,	+0	;NO. OF ARGS. IN FCN. CALL OR INDEXED VAR.
$ TLCTTW,	+0	;COMF. WORD TEMP.
$ TLTOPC,	+0	;"PROG.CTR." FOR GEN. CODE
$ TLSTPC,	+0	;"PROG. COUNTER" FOR GEN. CODE,CURR. BLOCK
$ TLTYCT,	+0	;TYPE (0,1, OR 2) OF CURR. FCN. NAME
$ TLCOMR,	+0	;TYPE OF TLCOMF RESULT(0=FLOAT,1=FIX,2=STRING)
$ TLOPRP,	+0	;OPERATOR STACK REL PTR
$ BASBEG,	+0	;INITIAL TEXT POINTER FOR STATEMENT HEADER
$ TLGCOP,	+0	;GENC TEMP.
$ GOSUB,	+0	;GO SUB COUNTER FOR STACK UNDERFLOW
$B SAINTF,	+0	;FLAG BYTE USED BY SAINT FLAG OPS
$B MATCH,	+0	;MATCH FLAG FOR SYNTAX INTERPRETER
$B TLOPRF,	+0	;FLAG OPERAND -- QUIT ON 2ND IN ROW
$B PTOKE,	+0	;FLAG BYTE OF PREV. TOKEN INF.
$B TLFNAF,	+0	;COMF FLAG
$B CHVSRF,	+0	;CHAIN VS. R FLAG (0=CHAIN,1=R)
$B NSTO,	+0	;NO. OF ADDRESSES ON L.S. OF A LET STATEMENT
$B PTOKF,	+0	;PREV. TOKEN FLAG
$B TLCOFL,	+0	;CONDIT. EXPRESSION FLAG
$B TLLSFL,	+0	;"LEFT-SIDE" FLAG IN DOLET
$B TLFNAR,	+0	;NUMBER OF ARGS FOR FUNCTION
$B TLINFL,	+0	;FLAG - TOP-LEVEL=0, INSIDE=1
$B TLENBY,	+0	;CONTAINS "NEXTS" OR "HALT" OPERATOR
		.EVEN
LOAS=200.		;LENGTH OF OPERAND STACK
LOPS=50.		;LENGTH OF OPERATOR STACK
LCOS=300.		;LENGTH OF CODE STACK
	.=.+LOAS	;OPERAND STACK 
$ OASB,
	.=.+LOPS	;OPERATOR STACK 
$B OPSB,
	.=.+LCOS	;CODE STACK 
$B COSB,
	.EVEN
$ DUMSTR,	0		;A DUMMY STRING AND NULL AT THAT
	.WORD	0
	.WORD	0
;END VARIABLES BELONGING IN SWAP AREA-------------------------------

$ STACK,	0	;STACK SAVE LOCATION
PHLB	=.-BEGPDA		;LEXICAL BUFFER
LINBUF	=.		;LINE BUFFER ORIGIN
LINLEN	=	256.	;LINE BUFFER LENGTH IN BYTES
	.=	.+LINLEN
TTYBUF	=.		;TTY BUFFER ORIGIN

TTYLEN	=	90.	;TTY BUFFER LENGTH IN BYTES
	.=	.+TTYLEN
ENDPDA:			;END OF DATA AREA
ENDSTT:			;END OF THE STATIC AREA


	.=	ENDNZD	;NO REASON TO TAKE UP SPACE IN CORE FOR ZERO ITEMS
;THE GARBAGE COLLECTOR--------------------------------------------------
;WRITES A FILE OF ACTIVE STRINGS AND READS IT BACK THUS ELIMINATING 
;"HOLES" IN STRING SPACE. FIRST PASS MOVES SIGN OF FIRST WORD OF STRING TO SIGN OF
;LENGTH WORD IN HEADER AND CLEARS SIGN IN STRING. THIS MAKES THE STRING SIGN AVAILABLE
;FOR USE AS A FLAG.  THE SECOND PASS SETS THIS FLAG TO INDICATE THAT A STRING
;IS POINTED TO BY A HEADER, AND USES IT TO SET THE "MULTIPLE-REFERENCE"
;FLAG IN ANY HEADERS WHICH POINT TO STRINGS WHICH HAVE BEEN POINTED TO BY EARLIER
;HEADERS. ON THE THIRD PASS THE STRING SIGN BITS ARE RESTORED AND THE STRINGS
;ARE WRITTEN IN A DISK FILE.  THEN THE NEW ADDRESS OF A STRING IS STORED WHERE
;IT USED TO LIVE. HEADERS WITH THE "MULT-REF" BIT SET PICK UP THE NEW STRING
;LOCATION FROM THE OLD STRING HOME.  THEN THE DISK FILE IS READ IN OVER THE
;OLD STRING AREA.

;THE GARBAGE COLLECTOR WORKS ON THE PTA AS WELL AS THE PDA.

;SINCE THE GARBAG COLLECTOR IS LONGER THAN 256 WORDS, IT READS THE
;SECOND HALF OF ITS CODE INTO THE FIP DIRECTORY BUFFER BEFORE DOING
;ANYTHING ELSE.

GCSEG2	=10			;SEGMENT WITH SECOND HALF

GARBAG:	MOV	#GCSEG2,R2	;GET SECOND SEG OF THIS PROGRAM
	MOVB	#-1,@#FIBLOG	;GOING TO KILL FIBUF
	JSR	PC,@#READ	;INTO THE OTHER BUFFER
	MOVB	#-1,@#FIBLOG	;GOING TO KILL FIBUF
	ADD	#14,R4		;SKIP OVER FILE INFO
	MOV	#GCJOBO-GARB71,R2	;PLACE TO STORE JOB CONSTANTS
	ADD	PC,R2		;MAKE AN INSENSITIVE  POINTER
GARB71:	MOV	(R4)+,(R2)+	;GCJOB
	MOV	(R4)+,(R2)+	;GCR1
	MOV	@#FIJBDA,R5	;PROCURE SAVED USER SP
	MOV	JDSP(R5),R5	;TO ACCESS CSR ITEMS SAVED ON STACK
	ADD	GCJOBO,R5	;COMES RELATIVIZED
	MOV	R5,(R2)+	;KEEP IT AS GCSP
	ADD	#SVSCTH+2,R5	;INDEX DOWN TO GET AT SPTA
	MOV	#5,R4		;NUMBER OF STACK ITEMS
	MOV	GCJOBO,R3	;MAKE THEM ABS
GARB80:	MOV	-(R5),(R2)	;THEY ARE SCTH,SPTA,SPDA,R6CORGAND R1CORG
	ADD	R3,(R2)+	;MAKE ABSOLUTE
	SOB	R4,GARB80	;LOOP
	BIC	#CALERR,@GCJOBO	;INITIALIZE GC ERROR FLAG
	MOV	#100000,R3	;SIGN BIT
	MOV	GCSPDA,R0	;SET UP POINTER TO LOCAL SPDA
	MOV	PLUDYN(R0),R3	;INSURE STRING PTR EVEN
	BIC	#177776,R3	;AS EVERYTHING BELOW
	ADD	R3,PLUDYN(R0)	;ASSUMES IT IS
	MOV	R3,PDAODD(R0)	;SAVE TO RESTORE AT END
	MOV	GCSPTA,R2	;PROGRAM POINTER MUST ALSO BE EVEN
	MOV	PLUDYN(R2),R3	;FOR SAME REASON
	BIC	#177776,R3	;SO GET ITS LOW BIT
	ADD	R3,PLUDYN(R2)	;AND ADD TO POINTER
	MOV	R3,PTAODD(R0)	;AND SAVE TO RESTORE
	JSR	PC,GCOLEC	;COLLECT STRINGS
	MOV	GCSPDA,R0	;DECIDE WHETHER TO COLLECT PUSHPOP
	CMP	CAAREA(R0),#TAGNOM	;ONLY IF OUT OF TAG SPACE CALL
	BNE	GCOL14		;NO
	MOV	#100000,R3	;NEED SIGN BIT ALL HANDY
	MOV	GCSPTA,R0	;COLLECT IT
	JSR	PC,GCOLEC	;ANY OLD PUSHPOP LAYING AROUND?
	BR	GCOL14

GCOLEC:	MOV	#100000,R3	;USEFUL CONSTANT
	JSR	PC,GCPASS	;FIRST PASS, SAVE SIGN BITS OF INITIAL STRING WORD
	+	GCPAS1-GARBAG+FIPBUF
	JSR	PC,GCPASS	;SECOND PASS, SET MREF BITS IN HEADERS
	+	GCPAS2-GARBAG+FIPBUF

;THIRD AND HAIRIEST PASS STARTS HERE
;SETS UP	FILE BUFFER POINTER
;	FILE BYTE COUNT
;	NEXT SECTOR
;	FILE SECTOR ADDRESS FOR BEGINNING OF STRING FILE
;
	MOV	#SWBASE+SWBASE+SWBASE+SWBASE+FIBASE,-(SP)	;COMPUTE USERS
	MOVB	@#FIJOB,R2	;SWAP AREA
	ASR	R2
GCOL33:	DEC	R2		;ON DISK
	BEQ	GCOL32		;TO USE AS THE
	ADD	@#CORMXA,(SP)	;PLACE FOR THE
	BR	GCOL33		;STRING FILE
GCOL32:	MOV	(SP),GCISEC	;INITIAL SECTOR
	MOV	(SP)+,GCNSEC	;NEXT SECTOR
	CLR	GCOFBC		;OUTPUT FILE BYTE COUNT
	MOV	#BASBUF,-(SP)	;OUTPUT FILE POINTER-REL
	ADD	GCSPDA,(SP)
	MOV	(SP),GCWBUF	;SET UP TO OUTPUT THE BUFFER
	MOV	(SP)+,GCBUFP
	JSR	PC,GCPASS	;THIRD PASS, WRITE STRING FILE
	+	GCPAS3-GARBAG+FIPBUF
				;FILE WRITTEN, NOW READ IT BACK
	MOV	R0,R3		;COMPUTE BASE OF STRINGS REL SPXA
	ADD	#PLUSTA,R3	;HIDDEN IN HERE
	MOV	(R3),R3		;GOT IT
	ADD	R0,R3		;MAKE ABSOLUTE
	MOV	R3,-(SP)	;SAVE IT FOR LATER
	MOV	R3,GCRBUF	;READ ALL BACK TO HERE IN A LUMP
	MOV	GCISEC,R2	;START FROM THIS SECTOR
	MOV	GCNSEC,R3
	SUB	R2,R3
	BEQ	GCOL73		;IN CASE IT CAN'T HANDLE ZERO
	MOV	R3,@#FICNT	;NUMBER OF SECTORS TO READ
	JSR	R5,@#PARSET
	+	RFUN
GCRBUF:	+	0
GCOL73:	MOV	#1,@#FICNT	;RESTORE ONE FOR FIP
				;NOW WHAT'S LEFT IN BUFFER
	MOV	GCBUFP,R2	;BUFFER POINTER
	MOV	(SP)+,R5	;BASE OF STRINGS
	MOV	GCOFBC,R4	;TOTAL BYTES OF STRING
	ADD	R4,R5		;LAST +2 NEW STRING SPOT
	MOV	R5,PLUDYN(R0)	;AND UPDATE THE FREE POINTER
	SUB	R0,PLUDYN(R0)	;TO REFLECT GARBAGE COLLECTED
	BIC	#177000,R4	;TRUNCATE COUNT
	ASR	R4		;KNOWN TO BE EVEN
	BEQ	GCOL20		;DONE	(RTS PC)
GCOL72:	MOV	-(R2),-(R5)	;WORD BUF TO STR
	SOB	R4,GCOL72
GCOL20:	RTS	PC		;FINISHED WITH THIS AREA
;GARBAGE COLLECTOR'S PART OF CORE ALLOCATOR
;THE TOTAL AMOUNT OF FREE SPACE IS COMPUTED AS THE SUM OF THE 
;MAGNITUDES OF THE DIFFERENCE BETWEEN THE LIMIT AND THE CURRENT POINTERS
;FOR EACH GROWTH AREA. EACH AREA HAS A NOMINAL SIZE WHICH CA IS TRYING TO ARRANGE
;TO HANG FREE, EXCEPT THE STRING AREA WHICH GETS, IN ADDITION TO ITS
;NOMINAL ALLOTMENT, ANY LEFT OVERS.  IF THE TOTAL FREE SPACE IS LESS
;THAN THE TOTAL NOMINAL SPACE DESIRED MORE CORE IS REQUESTED.
;OTHERWISE THE EXISTING SPACE IS SIMPLY REARRANGED. THE BLOCK OF CELLS
;AT R1SNOM IN THE DATA AREA SPECIFIES TO THE CORE ALLOCATOR THE NUMBER OF FREE
;CELLS WANTED IN EACH GROWTH AREA.  SOME OF THESE ARE TWEAKED BY VARIOUS
;ENTRANCES TO THE ALLOCATOR.  THE CELLS XXXNOM CONTAIN THE NOMINAL WHICH WILL
;BE IN THIS BLOCK OF CELLS WHEN THE XXX AREA IS TO BE MEDDLED WITH.

;GET AREA POINTER BACK

GCOL14:	MOV	GCSPDA,R0	;GET BASAREA NOM POINTER CORRES. TO PART. CALL OF CA
	CMP	CAAREA(R0),#STRNOM	;NO ADJUSTMENT TO STRNOM
	BEQ	CALC04		;ALLOWED
	CLR	STRNOM(R0)	;LET IT JUST GET LEFTOVERS
	MOV	CAAREA(R0),-(SP);PICK UP AREA PTR
	ADD	R0,(SP)		;MAKE ABSOLUTE
	MOV	@(SP),-(SP)	;MULTIPLY NOMINAL SPACE
	ASR	(SP)		;PARAMETER BY 1.25
	ASR	(SP)
	ASR	(SP)		;LESS ONE IF ODD
	ASL	(SP)
	ADD	(SP)+,@(SP)+	;UPDATE PARAMETER HERE
CALC04:	MOV	@#FIJBDA,R5	;ACCESS TO JOB DATA
	MOVB	JDSIZ0(R5),CACORE(R0)	;CURRENT SIZE IN K CORE
CALC05:	MOV	#R1SNOM,R3	;PUNISH EACH NOM NOW
	ADD	R0,R3		;THUS REDUCING THE ENTRY BOOSTED
	MOV	#4,R2		;ONE TO 1 3/32 ORIGINAL VALUE
CALC01:	MOV	(R3),-(SP)	;OLD VALUE
	ASR	(SP)		;TIMES 1/16
	ASR	(SP)
	ASR	(SP)
	ASR	(SP)
	ASR	(SP)		;LESS ONE IF ODD
	ASL	(SP)
	SUB	(SP)+,(R3)	;UPDATE HERE
	CMP	(R3)+,#40	;MINIMUM VALUE
	BGE	CALC03
	MOV	#60,-2(R3)	;10 IS LEAST ALLOWING RECUPERATION
CALC03:	SOB	R2,CALC01	;LOOP THROUGH ALL PARAMETERS
	MOV	R0,R3		;TO COMPUTE SOME TOTALS
	ADD	#R1SNOM,R3	;MAKE THIS ABSOLUTE POINTER
	ADD	(R3)+,R2	;INTO NOMINAL AREA
	ADD	(R3)+,R2	;AND ACCUMULATE
	ADD	(R3)+,R2
	ADD	(R3)+,R2	;PRG
	MOV	R2,NSTRNM(R0)	;ALL NOMS BUT STRING HERE
	TST	(R3)+		;SKIP OVER STRNOW
	ADD	(R3),R2		;AND ALL OF THEM
	MOV	R2,SUMNOM(R0)	;HERE
	MOV	GCR1,R2		;MAIN BODY OF CA - FREE SPACE
	SUB	GCR6CO,R2	;FOR R1 STACK
	JSR	PC,CASUMF	;STRING HEADER & STRING
	MOV	GCSPTA,R0	;AND IN
	JSR	PC,CASUMF	;STATEMENT HEADER & STATEMENTS
	MOV	GCSPDA,R0	;LOCAL BASE AGAIN
CAGRAB:	CMP	R2,SUMNOM(R0)	;IF TOTAL IS SMALL NEED MORE CORE
	BGE	CA1		;NO NEED ASK FOR MORE
	CMP	CACORE(R0),@#CORMXA	;SEE IF ANY MORE AVAILABLE
	BLT	CA94		;YES,MORE TO BE HAD
	CMP	NSTRNM(R0),#300	;IF LESS THAN THIS
	BGE	CALC05		;PUNISH ALL PARAMETERS AND TRY AGAIN
	BIS	#CALERR,@GCJOBO	;SIGNAL TOO LITTLE RECOVERED
	MOV	R0,R3		;GET POINTER TO R1 NOMINAL
	ADD	#R1SNOM,R3	;ACCESS TO NOMS
	MOV	#40,R4		;SIZE FOR R1NOM
	CMP	R2,R4		;FREE SPACE FOR IT?
	BGE	CA95		;YES
	BIS	#CALER2,@GCJOBO	;DISASTER IS INEVITABLE
	BR	CA96		;NO STACK FOR RECOVERY
CA95:	SUB	R4,R2		;REMOVE FROM POOL
CA96:	MOV	R4,(R3)+	;AND GIVE TO R1 STACK
	ASR	R2		;NOW GIVE 1/4 EACH TO TO HDR AND STR
	ASR	R2		;FOR USE IN RECOVERY
	ASR	R2		;WE WANT IT TO BE EVEN, SO DIVIDE...
	ASL	R2		;AND MULTIPLY
	MOV	R2,(R3)+	;SET STATEMENT HEADER SPACE
	MOV	R2,(R3)+	;SOME PROGRAM SPACE
	MOV	R2,(R3)+	;AND A STRING HEADER OR TWO
	MOV	R2,(R3)+	;AND EVEN A STRING OR TWO
	BR	CALC33		;NOW GET OUT

CA94:	INC	CACORE(R0)	;ONE MORE, PLEASE
	MOV	GCSPTA,R4	;ADD THIS TO STATEMENT AREA
	ADD	#BLKLEN,PLULIM(R4)	;(1 BLOCK OF CORE)
	ADD	#BLKLEN,R2	;AND TO SUM
	BR	CAGRAB
CA1:	SUB	NSTRNM(R0),R2	;PUT ALL EXTRA SPACE
	MOV	R2,STRNOW(R0)	;IN STRING AREA
CALC33:	MOV	#-1.,BASSEG(R0)	;INDICATE BASBUF USED
	MOVB	@#FIJOB,R0	;ARG FOR UNLOCK
	JMP	@#UNLOCK	;UNLOCK HIM
;ROUTINE TO SUM UP FREE SPACE IN SP-A AREA
;SP-A IN R0
;SUMS INTO R2

CASUMF:	ADD	#PLUDYN,R0	;AIM AT RELEVENT BLOCK
	SUB	(R0)+,R2	;+DYN
	ADD	(R0)+,R2	;-DYM
	ADD	(R0)+,R2	;+LIM
	SUB	(R0),R2		;-LIM
	RTS	PC

GCPASS:	MOV	R0,R2		;MAKE A PASS OVER LIST
	TST	(R2)		;NO FIRST ITEM?
	BEQ	GCOL45		;DONE THEN
	CMP	R2,GCSPDA	;SEE WHICH AREA IN QUESTION
	BHI	GCPROP		;IS THE PROGRAM AREA
	ADD	(R2),R2		;SKIP FIRST ITEM
GCOL03:	MOV	@(SP),-(SP)	;ADDRESS OF SUBR
	TST	(R2)		;END OF LIST?
	BEQ	GCOL01		;NOW DO FIRST ITEM
	ADD	(R2),R2		;HEADER POINTER
	MOV	R2,R5
	TST	4(R5)		;TEST LENGTH
	JSR	PC,@(SP)+	;CALL OPERATOR
	BR	GCOL03		;AND LOOP

GCOL01:	MOV	R0,R2		;NOW DO FIRST ONE ON LIST
	ADD	(R2),R2		;CUE IT UP
GCOL83:	MOV	R2,R5
	TST	4(R5)
	JSR	PC,@(SP)+	;PROCESS IT
GCOL45:	ADD	#2,(SP)		;SKIP OVER OPERATOR
	RTS	PC

GCPROP:	MOV	@(SP),-(SP)	;IN CASE OF PROGRAM AREA
GCOL85:	TST	(R2)		;THE STATEMENT
	BEQ	GCOL81		;AND MUST BE KEPT TILL LAST
	ADD	(R2),R2		;SO THAT THERE IS GUARANTEED
	CMP	R2,GCSCTH	;FREE AREA ABOVE IT
	BEQ	GCOL85		;FOR ANY ACCRETIONS
	MOV	R2,R5		;OTHERWISE, THIS DOES
	TST	4(R5)		;THE SAVE THING AS THE PASS FOR SPDA
	JSR	PC,@(SP)+
	BR	GCPROP

GCOL81:	MOV	GCSCTH,R2	;NOW DO THE CURRENT
	BR	GCOL83		;STATEMENT IN SCTH MAY BE UNDER CONSTRUCTION

GCPAS1:	BEQ	GCOL02		;IGNORE 0 LENGTH STRINGS
	ADD	2(R5),R5	;STRING POINTER
	TST	(R5)		;SIGN OF FIRST WORD OF STRING SET?
	BPL	GCOL02		;NO
	BIS	R3,4(R2)	;SAVE IN SIGN OF LENGTH
	BIC	R3,(R5)		;CLEAR STRING SIGN
GCOL02:	RTS	PC
GCPAS2:	BEQ	GCOL40		;IGNOR 0 LENGTH ITEMS
	ADD	2(R5),R5	;STRING POINTER
	TST	(R5)		;PREV REFERENCED?
	BPL	GCOL05		;NO
	BIS	R3,2(R2)	;YES, SAY SO IN HEADER
GCOL05:	BIS	R3,(R5)		;NOW INDICATE REFERENCED
GCOL40:	RTS	PC

GCPAS3:	BNE	GCOL30		;NON-0 LENGTH STRING
	JSR	PC,GCNEWP	;RELOCATE EVEN ZERO LENGTH STRINGS
	BR	GCOL41

GCOL30:	TST	2(R2)		;TEST PRIM OR SEC REF FLAG
	BPL	GCOL08		;BRANCH IF THIS IS PRIMARY REFERENCE
	BIC	R3,4(R2)	;CLEAR FLAG SIGN
	BIC	R3,2(R2)	;CLEAR POINTER SIGN
	ADD	2(R5),R5	;STRING POINTER
	JSR	PC,GCNEWO	;SAVE IN HEADER
	BR	GCOL41

GCOL08:	ADD	2(R5),R5	;STRING POINTER
	BIC	R3,(R5)		;RESTORE STRING SIGN
	MOV	4(R2),R4	;BY CLEARING MINUS
	BPL	GCOL09		;AND SETTING ONLY
	BIS	R3,(R5)		;IF ORIGINALLY SET
	BIC	R3,4(R2)	;CLEAR LENGTH SIGN
	BIC	R3,R4		;ALSO IN COPY
GCOL09:	JSR	PC,GCNEWP	;NEW POINTER IN HEADER
	ASR	R4		;CONVERT BYTE COUNT
	ADC	R4		;INCLUDING DUMMY BYTE
	MOV	R5,-(SP)	;DUMP STRING OUT ONTO THE DISK
	MOV	GCOFBC,-(SP)	;SAVE FILE BYTE COUNT
GCOL13:	MOV	(R5)+,@GCBUFP	;MOVE WORD TO BUFFER
	ADD	#2,GCBUFP	;AND THE BUFFER POINTER
	ADD	#2,GCOFBC	;UPDATE OUTPUT FILE BYTE COUNT
	MOV	GCOFBC,-(SP)	;SHOULD BUFFER BE DUMPED?
	BIC	#177000,(SP)+	;HOLD 1000 BYTES
	BNE	GCOL12		;NO
	MOV	R2,-(SP)	;SAVE R2 FOR A WHILE
	MOV	GCNSEC,R2	;FILE SECTOR ADX
	JSR	R5,@#PARSET
	+	WFUN
GCWBUF:	+	0		;BUFFER CORE ADDRESS
	INC	GCNSEC		;NEXT SECTOR
	MOV	GCWBUF,GCBUFP	;BEGIN A NEW BUFFER
	MOV	(SP)+,R2	;RESTORE R2
GCOL12:	SOB	R4,GCOL13	;MOVE REST OF STRING
	MOV	(SP)+,@(SP)+	;FILE BYTE COUNT TO OLD STRING
GCOL41:	RTS	PC
;MAKE AND STORE A POINTER TO RELOCATED STRING

GCNEWO:	MOV	(R5),-(SP)	;OLD FILE BYTE POINTER
	BR	GCNEW1

GCNEWP:	MOV	GCOFBC,-(SP)	;PICK UP FILE BYTE COUNTER
GCNEW1:	MOV	R0,-(SP)	;NOW GET BASE OF STRINGS &
	ADD	#PLUSTA,(SP)	;ADD IN PLEASE
	ADD	@(SP)+,(SP)	;FROM PLUSTA FOR AREA
	ADD	R0,(SP)		;ABSOLUTE NOW
	SUB	R2,(SP)		;REL CURRENT HEADER
	MOV	(SP)+,2(R2)	;SAVE IN HEADER
	RTS	PC
;
GCJOBO:	+	0		;JOBORG
GCR1:	+	0		;R1
GCSP:	+	0		;SP
GCSCTH:	+	0		;SCTH
GCSPTA:	+	0		;SPTA
GCSPDA:	+	0		;SPDA
GCR1CO:	+	0		;AND R1 STACK ORIGIN
GCR6CO:	+	0		;R6CORG
GCBUFP:	+	0		;CURRENT BUFFER POINTER
GCOFBC:	+	0		;OUTPUT FILE BYTE COUNT
GCISEC:	+	0		;INITIAL SEGMENT
GCNSEC:	+	0		;NEXT SECTOR
;CORE ALLOC NON-RESIDENT SEGMENT-------------------------------------
CAJOBO:	+	0
CAR1:	+	0
CASP:	+	0
CASPTA:	+	0
CASPDA:	+	0
CAR1CO:	+	0
CAR6CO:	+	0		;R6CORG
R1SOFF:	+	0		;OFFSET FOR R1 STACK
PDAOFF:	+	0		;OFFSET FOR PDA
PTAOFF:	+	0		;OFFSET FOR PTA

CALC:
CALC00:	ADD	#14,R4		;SKIP OVER FILE INFO
	MOV	#FIPBUF,R2	;PLACE TO STORE JOB CONSTANTS
	MOV	(R4)+,(R2)+	;CAJOBO
	MOV	(R4)+,(R2)+	;GCR1
	MOV	@#FIJBDA,R5	;USER JOB DATA BLOCK PTR
	MOV	JDSP(R5),R5	;SP ACCESS TO CSR
	ADD	CAJOBO,R5	;MAKE ABS
	MOV	R5,(R2)+	;SAVE LOCALLY IN CASP
	ADD	#SVSCTH,R5	;TO ACCESS SPTA
	MOV	#4,R4		;NUMBER OF STACK ITEMS
	MOV	CAJOBO,R3	;MAKE THEM ABS
CALC80:	MOV	-(R5),(R2)	;THEY ARE SPTA,SPDA,R1CORG AND R6CORG
	ADD	R3,(R2)+	;MAKE ABSOLUTE
	SOB	R4,CALC80	;LOOP
	MOV	CASPDA,R0	;BASE FOR NOM
	MOV	CAR1,R1
	MOV	R1SNOM(R0),R4	;GET NOMINAL R1 SPACE
	SUB	R1,R4		;LESS CURRENT POINTER
	ADD	CAR6CO,R4	;PLUS LOWER LIMIT
	MOV	R4,R1SOFF	;SAVE THIS OFFSET
	ADD	CAR1CO,R4	;NEW R1 STACK ORIGIN
	ADD	HDRNOM(R0),R4	;BY SEEING HOW IT MOVES FROM BOTTOM
	SUB	MINDYN(R0),R4	;(WHICH IS R1 STACK ORG)
	SUB	R0,R4		;OFFSET FOR DATA AREA
	MOV	R4,PDAOFF	;AND SAVE IT
	ADD	STRNOW(R0),R4	;TO GET TO BOUNDARY OF PDATA AND PROGRAM
	ADD	PLUDYN(R0),R4	;ADD TWO PIECES
	ADD	R0,R4		;NOW ABSOLUTE NEW ADDRESS OF BOUNDARY
	MOV	CASPTA,R2	;PROGRAM BASE
	ADD	TAGNOM(R0),R4	;NOW COMPUTE LAST OFFSET
	SUB	MINDYN(R2),R4	;SAME WAY
	SUB	R2,R4		;NOW OFFSET FOR PROGRAM AREA
	MOV	R4,PTAOFF	;AND SAVE
	TST	PDAOFF		;SEE WHICH WAY PDA GOES
	BPL	CA10		;IF UP MOVE PROGRAM,DATA,STACK
	JSR	PC,CAMR1S	;IF DOWN, MOVE STACK
	JSR	PC,CAMPDA	;	DATA
	JSR	PC,CAMPTA	;	PROGRAM
	BR	CA99		;WHEH!
CA10:	JSR	PC,CAMPTA	;MOVE PROGRAM
	JSR	PC,CAMPDA	;	DATA
	JSR	PC,CAMR1S	;	STACK
CA99:	MOV	R1SOFF,R5	;UPDATE STRING HEADERS ON R1 STACK
	SUB	PDAOFF,R5	;BETWEEN R1S AND PDA
	MOV	MINDYN(R0),R4	;AND TO HEADER ACTIVE REGION
	CMP	(R0),R4		;IS FIRST HEADER ON STACK?
	BGE	CA98		;NO, SO NONE TO RELOC
	ADD	R5,(R0)		;YES,SO UPDATE POINTER
	ADD	(R0),R0		;AND GET ABS POINTER TO HEADER ON STACK
CA97:	SUB	R5,2(R0)	;NOW IT IS DIFFERENT DISTANCE TO STRING
	MOV	R0,R3
	ADD	(R0),R0		;NEXT ITEM
	CMP	R0,CAR1CO	;DOES IT POINT OFF STACK?
	BLO	CA97		;NO
	SUB	R5,(R3)		;YE, BETTER RELOC
CA98:	MOV	CASPDA,R0	;RESTORE BASE
	MOV	CASP,R5		;STACK ACCESS
	ADD	R1SOFF,SVR1CO(R5)
	ADD	R1SOFF,SVR1RI(R5)
	ADD	R1SOFF,SVR1(R5)
	JSR	PC,CA98S		;CLEAR FREE STRING HEADER SPACE
	MOV	CASPTA,R0		;AND ALSO
	JSR	PC,CA98S		;CLEAR FREE TAG SPACE
	MOV	CASPDA,R0		;GET BASE
	MOV	CASPTA,R2		;ALSO TO ACCESS THE PROGRAM AREA
	SUB	PDAODD(R0),PLUDYN(R0)	;RESTORE POSSIBLE ODD STR PTR
	SUB	PTAODD(R0),PLUDYN(R2)	;AND POSSIBLE ODD PRO PTR
	MOVB	@#FIJOB,R0
	JMP	@#UNLOCK		;FREE USER FROM CORE

CA98S:	MOV	MINDYN(R0),R2	;USE R2 FOR COUNT
	SUB	MINLIM(R0),R2	;OF NUMBER OF FREE BYTES
	ASR	R2		;ERR, I MEAN WORDS
	ADD	MINDYN(R0),R0	;POINTER TO HIGH END OF FREE AREA
CA98A:	CLR	-(R0)		;CLEAR ONE WORD
	SOB	R2,CA98A	;AND WORK UNTIL DONE
	RTS	PC

;SUBROUTINE TO MOVE THE PDA

CAMPDA:	MOV	#STRNOW,R3	;SET UP ACCESS TO NOMS
	ADD	R0,R3		;ABSOLUTE
	MOV	PDAOFF,R4	;AND OFFSET
	JSR	PC,CAMOVE	;MOVE IT
	MOV	PDAOFF,R0	;PICK UP OFFSET
	ADD	R0,CASPDA	;INSTALL IT HERE
	MOV	CASP,R5		;ACCESS POINTER TO STACK
	ADD	R0,SVSPDA(R5)	;UPDAT SAVED SPDA
	MOV	#9.,R3		;AND MANY OTHER PLACES
CA13:	ADD	R0,(R5)+	;ALL IN CSR AREA
	SOB	R3,CA13
	MOV	CASPDA,R0	;RESTORE DATA POINTER
	RTS	PC

CAMPTA:	MOV	R0,R3		;MAKE AN ABSOLUTE POINTER
	ADD	#PRONOM,R3	;TO NOMINALS AREA
	MOV	CASPTA,R0	;MOVE PROGRAM AREA
	MOV	PTAOFF,R4	;GET OFFSET
	JSR	PC,CAMOVE	;UP OR DOWN AS APPROPRIATE
	MOV	PTAOFF,R0	;INSTALL OFFSET
	ADD	R0,CASPTA	;SAVE NEW BASE FOR PROGRAM
	MOV	CASP,R5		;ACCESS PTR
	ADD	R0,SVSPTA(R5)	;UPDATE SAVE SPTA AND SCTH
	ADD	R0,SVSCTH(R5)
	ADD	R0,SVR5RI(R5)	;AND IPC SOMETIMES
	MOV	CASPDA,R0	;RETRIEVE SPDA
	RTS	PC

CAMR1S:	MOV	CAR1CO,R2	;SEE HOW MUCH JUNK ON STACK
	MOV	R1SOFF,R4	;GET STACK OFFSET
	BPL	CAMR1A		;IF IT GOES UP
	MOV	R1,R5		;IF DOWN MOVE IT NOW
	ADD	R1,R4		;MOVE IT TO HERE
	SUB	R1,R2		;WHICH NEEDS TO BE MOVED
	JSR	PC,CAMOVD	;CALL  MOVING COMPANY
	MOV	R4,CAR1CO	;MOVING COMPANY LEAVES USEFUL EMPTY BOX
	RTS	PC

CAMR1A:	MOV	R2,R5		;PRESENT BASE OF STACK
	SUB	R1,R2		;NUMBER BYTES TO BE MOVED
	ADD	R5,R4		;NEW BASE
	MOV	R4,CAR1CO	;SAVE  IT
	JMP	CAMOVU		;TAKE IT FELLOWS
;ROUTINE TO MOVE AREA TO ESTABLISH NOMINAL FREE SPACE.
;ASSUMES BASE FOR AREA IN R0.  RESETS LIMIT PARAMETERS.
;RETURNS UPDATED BASE IN R0.

CAMOVE:	MOV	PLUDYN(R0),R5	;SET NEW UPPER LIMIT
	ADD	(R3),R5		;TO CURRENT POINT PLUS NOMINAL
	MOV	R5,PLULIM(R0)	;NOW IT IS SET
	MOV	MINDYN(R0),R5	;SET NEW LOWER LIMIT
	SUB	-(R3),R5	;TO CURRENT POINT LESS NOMINAL
	MOV	R5,MINLIM(R0)	;SET NOW
	MOV	PLUDYN(R0),R2	;COMPUTE ACTIVE REGION LENGTH
	SUB	MINDYN(R0),R2	;TO KNOW HOW MUCH TO MOVE
	MOV	PLUDYN(R0),R5	;UPPER STARTING LOC
	ADD	R0,R5		;(OR ENDING LOC)
	TST	R4		;DEPENDING ON THIS SIGN, MUST MOVE UP OR DOWN
	BEQ	CA3		;OR NO MOVE AT ALL
	BMI	CA4		;DOWN, SO ATART AT MIN END
	ADD	R5,R4		;UP FROM PLUDYN TO HERE
CAMOVU:	ASR	R2		;ONLY HALF AS MANY WORDS AS BYTES
	BEQ	CA3
CA2:	MOV	-(R5),-(R4)	;MOVE ONE WORD
	SOB	R2,CA2		;THESE MANY TIMES
	RTS	PC

CA4:	SUB	R2,R5		;ABS PTR TO MINDYN TO START FROM
	ADD	R5,R4		;TO HERE
CAMOVD:	ASR	R2		;HALVE COUNT
	BEQ	CA3
CA5:	MOV	(R5)+,(R4)+	;IN THIS ORDER TO AVOID OVERLAP
	SOB	R2,CA5		;THIS MANY WORDS
CA3:	RTS	PC
CALEND:				;LAST LOCATION+2 USED IN CA SEGMENT
;THIS IS THE ONE TIME CODE FOR INITIALIZING THE MONITOR
;IT'S PRETTY UGLY, BUT IT IS HARDLY EVER USED, SO WHO CARES

INIT:	RESET			;CLEAR EVERYTHING
	MOV	#PR7,PS		;NO INTERRUPTS FOR NOW
	MOV	#SYSTAK,SP	;INITIALIZE STACK
	JSR	R5,MESSAG	;NOW FIND OUT WHAT HE WANTS
	+	INIMES		;"LOAD,DUMP,START,REFRESH, OR ODT?
	JSR	PC,GETIN	;AND NOW WAIT FOR RESPONSE
	CMPB	(R1),#'R	;IS IT REFRESH?
	BEQ	INI01		;YES
	CMPB	(R1),#'L	;IS IT LOAD?
	BEQ	INI03		;YES--LOAD SYSTEM FROM DISK
	CMPB	(R1),#'D	;IS IT DUMP?
	BEQ	INI04		;YES--SAVE CORE IMAGE ON DISK
	CMPB	(R1),#'O	;HOW ABOUT ODT?
	BEQ	INI02		;YES-WE CAN DO THAT!
				;IT MUST BE START
	JSR	PC,FIPINI	;INITIALIZE SAT, FILES, ETC.
	MOV	#PR7,PS		;AVOID INTERRUPTS AGAIN
	JSR	PC,CORINI	;SET UP FREE CORE LIST
	JSR	PC,DDBINI	;INITIALIZE DDB'S FOR ALL DEVICES
	JSR	PC,LOGUIN	;LOG USER IN UNDER [1,2]?
	JSR	PC,DATINI	;GET TIME OF DAY AND DATE
	JSR	PC,SCHINI	;INITIALIZE SCHEDULER ROUND ROBINS
	JSR	PC,TTINIT	;INITIALIZE TTY SERVICE
	JSR	PC,QUEINI	;INITIALIZE QUEUES
	JSR	PC,AIRINI	;WE ARE ON THE AIR
	MOV	#SYSTAK,SP	;RESET STACK
	CLR	PS		;DROP TO CPU PRIORITY 0
	JMP	NULJOB		;RSTS IS ON THE AIR!!!!

INI01:	JSR	PC,REFRSH	;GO REFRESH THE DISK, IF HE'S SERIOUS
	BR	INIT+2		;AND NOW WHAT?

INI02:	000003			;CALL ODT
	BR	INIT+2		;TRY IT AGAIN

INI03:	MOV	#5,R1		;READ WITHOUT INTERRUPT ON RF11
INI05:	RESET			;CLEAR ALL THE DISK REGISTERS
	MOV	#DSKWC,R0	;POINT TO WORD COUNT
	MOV	#-20000.,(R0)	;SET WORD COUNT FOR 20K
	MOV	R1,-(R0)	;AND FUNCTION
	TSTB	(R0)		;DONE YET
	BPL	.-2		;NOPE
	BR	INIT		;YES--NOW ASK ANOTHER QUESTION

INI04:	MOV	#3,R1		;FUNCTION IS WRITE WITHOUT INTERRUPT
	BR	INI05		;SO WRITE IT ALREADY
;ROUTINE TO LOG A USER IN UNDER [1,2] IF HE ASKS FOR IT
;NEEDED TO GET SYSTEM OFF THE GROUND ON STARTUP WITHOUT LIBRARY

LOGUIN:	JSR	R5,MESSAG	;DOES HE WANT THIS SERVICE?
	+	LOGMES		;"LOG YOU IN UNDER [1,2]?"
	JSR	PC,GETIN	;WAIT FOR RESPONSE
	CMPB	(R1),#'Y	;WAS IT "YES"?
	BNE	LOGU01		;NO, SO DON'T
	MOV	DEVTBL,R1	;ADDRESS OF DDB FOR LINE 0
	JSR	PC,TTICR9	;GO SET HIM UP AS A JOB
	MOV	JOBTBL+2,R4	;GET ADDRESS OF JOB DATA AREA
	MOV	#JFIRST+JFSYS,JDFLG(R4)	;SET FLAGS
	MOV	#2,JDUFD(R4)	;START BLOCK OF [1,2] UFD = 2
	MOV	#402,JDPPN(R4)	;PROJ-PROGRAMMER # = [1,2]
	BIC	#JSKEY,JBSTAT+2	;TTICR9 THOUGHT HE TYPED A DELIMITER---HE DIDN'T
LOGU01:	RTS	PC		;HE'S ALL LOGGED IN


;THIS ROUTINE INITIALIZES THE SCHEDULER TO NULJOB

SCHINI:	MOVB	#-1,SWAPF	;NO SWAP ONGOING
	CLRB	NEXT		;NO CHOSE JOB
	CLRB	JOB		;NO CURRENT JOB
	CLR	JOBPTR		;START SCAN AT BEGINNING
	MOV	#CORTBL,CORPTR	;DITTO
	MOV	#CORTBL,CORFOR	;DITTO
	RTS	PC		;ALL DONE


;ROUTINE TO TYPE OUT STARTING MESSAGE ON ALL TTY'S---------------------

AIRINI:	CLR	R0		;START WITH LINE 0
AIRIN2:	MOV	DEVTBL(R0),R1	;GET DDB ADDRESS
	JSR	R5,ASCOUT	;OUT WITH MESSAGE
	+	AIRMES		;"BTSS V00A"
	TST	(R0)+		;ON TO THE NEXT LINE
	CMP	R0,#NULINE+NULINE+2	;UNLESS WE'RE DONE
	BNE	AIRIN2		;NO SUCH LUCK
	RTS	PC		;NOW THEY NOW WE'RE HERE
;ROUTINE TO GET THE DATE AS DD-MON-YY***********************************
;THEN WE GET THE TIME AS HH:MM
;THEN WE GUESS YOUR WEIGHT AND FORTUNE

DATINI:	JSR	R5,MESSAG	;ASK HIM FOR DATE
	+	DAYMES
	JSR	PC,GETIN	;AND WAIT FOR HIM TO TYPE IT
	MOV	R1,R2		;POINTER TO START OF RESPONSE
	MOV	#FISTAK,R1	;MAKE A LITTLE R1 STACK
	JSR	PC,IATOI	;AND CONVERT DAY....
	BCS	DATI99		;BAD NUMBER--ASK AGAIN
	INC	R2		;SKIP DELIMITER
	MOV	#DATTBL+2,R4	;POINT TO TABLE OF MONTH NAMES
	MOV	#365.-31.,R0	;DAY 0 OF CURRENT MONTH
DATI01:	CMPB	(R4),(R2)	;MATCH PON FIRST CHARS?
	BEQ	DATI02		;LOOKS PROMISING...
DATI08:	ADD	#3,R4		;NO MATCH--ON TO NEXT MONTH
	MOVB	(R4)+,R5	;GET NUMBER OF DAYS IN THAT MONTH
	BEQ	DATI99		;END OF LIST
	SUB	R5,R0		;FIX UP DAY 0 OF MONTH
	BR	DATI01		;AND ON TO NEXT MONTH

DATI99:	JSR	R5,MESSAG	;YES-BAD DATE
	+	DAYBAD		;TELL HIM TO TRY AGAIN
	BR	DATINI		;UNTIL HE GETS IT RIGHT

DATI02:	MOV	R4,-(SP)	;SAVE POINTERS UNTIL WE'RE SURE
	MOV	R2,-(SP)	;THAT WE HAVE A MATCH
	CMPB	(R2)+,(R4)+	;FUDGE POINTERS---WE ALREADY KNOW EQUAL
	CMPB	(R2)+,(R4)+	;SECOND CHARS MATCH?
	BNE	DATI07		;NOPE-TRY NEXT MONTH
	CMPB	(R2)+,(R4)+	;THIRD CHARS TOO?
	BNE	DATI07		;NOPE-TRY NEXT MONTH
	CMPB	(SP)+,(SP)+	;WE HAVE MONTH---THROW OUT OLD POINTERS
	ADD	R0,(R1)		;YES, NOW WE HAVE DAY OF YEAR
	INC	R2		;SKIP DELIMITER AFTER MONTH
	JSR	PC,IATOI	;AND GET YEAR
	BCS	DATI99		;BAD YEAR (AREN'T THEY ALL....)
	CMP	(R1),#70.	;IS IT A REASONABLE YEAR?
	BHIS	DATI03		;YES
	JSR	R5,MESSAG	;NO--YEAR MUST BE > 1970
	+	LIEMES		;SO TELL HIM HE LIES
	BR	DATINI		;AND START ALL OVER AGAIN

DATI07:	MOV	(SP)+,R2	;NOT THIS MONTH--RESTORE POINTERS
	MOV	(SP)+,R4	;AND TRY NEXT MONTH
	BR	DATI08		;IF THERE IS A NEXT MONTH
DATI03:	MOV	(R1)+,R5	;GET YEAR ENTERED
	BIT	#3,R5		;IS IT A LEAP YEAR?
	BNE	DATI04		;NO
	CMP	(R1),#60.	;YES--IS IT AFTER FEBRUARY 28?
	BLE	DATI04		;IF SO, NO FUDGE NEEDED
	INC	(R1)		;FUDGE FOR THE 29 TH
DATI04:	SUB	#70.,R5		;YEAR - 70.
DATI05:	BEQ	DATI06		;COMPUTE (YEAR-70.)*1000+DAY
	ADD	#1000.,(R1)	;NEW YEAR
	DEC	R5		;UNTIL WE'RE UP THERE
	BNE	DATI05		;TAKES A LITTLE LONGER EVERY YEAR....
DATI06:	MOV	(R1)+,DATE	;NOW SET DATE


;NOW GET THE TIMEE OF DAY AS HH:MM AND SET IT TOO********************

TIMI00:	JSR	R5,MESSAG	;ASK FOR TIME
	+	TIMESG		;"HH:MM"
	JSR	PC,GETIN	;AND WAIT FOR HIM TO LOOK AT CLOCK
	MOV	R1,R2		;SET POINTER TO INPUT STRING IN R2
	MOV	#FISTAK,R1	;MAKE A LITTLE STACK
	JSR	PC,IATOI	;AND GET HOUR
	BCS	TIMI00		;IT DIDN'T LIKE THAT NUMBER
	CMP	(R1),#23.	;REASONABLE HOUR?
	BGT	TIMI00		;NOPE
	INC	R2		;SKIP DELIMITER
	JSR	PC,IATOI	;AND GET MINUTES
	BCS	TIMI00		;OOPS
	CMP	(R1),#60.	;LEGITIMATE?
	BGT	TIMI00		;NOPE
	CLR	R5		;NOW COMPUTE HOURS*60+MINIUTES
	MOV	2(R1),R4	;HOURS
TIMI01:	BEQ	TIMI02		;DONE
	ADD	#60.,R5		;MULTIPLY BY 60
	DEC	R4		;UNTIL DONE
	BR	TIMI01

TIMI02:	ADD	(R1),R5		;HOURS*60.+MINUTES
	NEG	R5		;- (  )
	ADD	#1440.,R5	;TIME A LA RSTS
	MOV	R5,TIME		;A TIME TO REMEMBER
	COM	LCS		;KEEP IT UP TO DATE
	RTS	PC		;ALL DONE

IATOI:	MOV	R2,-(SP)	;ATOI WITH V SET FOR 0 LENGTH STRINGS
	JSR	PC,ATOI		;DO THE REAL WORK
	BVS	IATOI1		;BAD NUMBER
	CMP	R2,(SP)		;LOOKS OK...DID POINTER MOVE
	BEQ	IATOI1		;NOPE-MUST HAVE BEEN BAD FIRST CHAR
	TST	(SP)+		;GET RID OF R2 AND CLEAR V
	BR	.+4		;AND GET OUT
IATOI1:	COM	(SP)+		;GET RID OF R2 AND SET V
	RTS	PC
;ROUTINE TO SET UP DDB'S FOR EVERY DEVICE IN THE SYSTEM
;THEY ARE COPIED FROM PROTOTYPICAL DDB'S PROVIDED WITH HANDLER

DDBINI:	MOV	#DEVTBL,R0	;ENTRY FOR TTY00
	MOV	#NULINE+1,R1	;# OF TTY'S IN SYSTEM
DDBI02:	JSR	R5,DDBI10	;SET UP A TTY DDB
	+	TTYDDB		;PROTOTYPE DDB
	MOV	R0,-(SP)	;DEVTBL ADDRESS+2 TO STACK
	SUB	#DEVTBL+2,(SP)	;DEVTBL INDEX PROPER
	MOVB	(SP)+,TTLINE-40(R4)	;PUT LINE INDEX INTO DDB
	SOB	R1,DDBI02	;REPEAT FOR ALL TTY'S
	MOV	#10,R1		;NOW FILL UP THE DTA SLOTS WITH PHONY'S
DDBI03:	MOV	#FONYDD,(R0)+	;SO THEY CAN'T BE ASSIGNED
	SOB	R1,DDBI03	;ANY OF THEM
	JSR	R5,DDBI10	;COPY THE PROTO LPT DDB
	+	LPTDDB
	JSR	R5,DDBI10	;NOW GET A PTR DDB
	+	PTRDDB		;AND COPY IT AS SHOWN
	JSR	R5,DDBI10	;AND THE PTP TOO
	+	PTPDDB		;SO IT WILL BE HAPPY
	RTS	PC		;HAPPINESS IS A WARM DDB


DDBI10:	BUFFER,	GETSML		;GET A BLOCK FROM FREE LIST
	BVC	.+4		;IF THERE ARE NONE, THAT'S VERY BAD
	HALT			;BAD,BAD,BAD
	MOV	R4,(R0)+	;PUT DDB ADDRESS IN DEVTBL
	MOV	(R5)+,R2	;NOW COPY DDB FROM PROTOTYPE
	MOV	#20,R3		;ALL 16. WORDS OF IT
DDBI11:	MOV	(R2)+,(R4)+	;MOVE A WORD
	SOB	R3,DDBI11	;AND ANOTHER ...UNTIL DONE
	RTS	R5		;AND THEN WE'RE DONE
TTYDDB:	+	2		;PROTOTYPE TTY DDB; INDEX=2
	+	100000		;ASSUME MODEL 33 TTY
	+	0		;TIME ASSIGNED
	-	TTPOS0		;HORIZONTAL POSITION
	+	0		;INPUT BUFFER POINTERS, ETC.
	+	0
	+	0
	+	0
	+	TTBFMX		;MAXIMUM # BLOCKS IN BUFFER CHAIN
	+	0		;OUTPUT BUFFER  POINTERS ET AL.
	+	0
	+	0
	+	0
	+	TTBFMX		;MAX # BLOCKS IN OUTPUT BUFFER
	-	TTPOS0		;# CHARS ON LINE
	+	0		;ETC

;PROTOTYPE PTR DDB:

PTRDDB:	+	PTRFLG+PTRHND	;FLAGS + INDEX
	+	0		;JOB #
	+	0		;TIME
	+	0		;V CHAR
	+	0		;BUFFER POINTERS...
	+	0
	+	0
	+	0
	+	PTRMAX		;MAX # BLOCKS IN BUFFER
	+	0		;REST ARE UNUSED
	+	0
	+	0
	+	0
	+	0
	+	0
	+	0
;PROTOTYPE PTP DDB:

PTPDDB:	+	PTPFLG+PTPHND	;FLAGS + INDEX
	+	0		;JOB #
	+	0		;TIME
	+	0
	+	0		;BUFFER POINTERS...
	+	0
	+	0
	+	0
	+	PTPMAX		;MAX # BLOCKS IN BUFFER
	+	0		;REST ARE UNUSED
	+	0
	+	0
	+	0
	+	0
	+	0
	+	0


;PROTOTYPE LPT DDB

LPTDDB:	+	LPTFLG+LPTHND	;FLAGS+ INDEX
	+	0		;JOB #
	+	0		;TIME ASSIGNED
	-	LPPOS0		;HORIZONTAL POSITION
	+	0		;BUFFER CONTROL PARAMETERS
	+	0
	+	0
	+	0
	+	LPTMAX		;MAX # BLOCKS IN BUFFER
	+	0		;UNUSED
	+	0
	+	0
	+	0
	+	0
	-	LPPOS0		;RESET VALUE FOR LPT LINE
	+	0		;INIT COUNT AND ASSIGN BIT
;THIS ROUTINE WILL SET UP THE FREE CORE LISTS
;FOR BOTH BIG AND SMALL BUFFERS.  IT ALSO INITIALIZES
;THE CORE ALLOCATION TABLE TO EVERYBODY OUT OF CORE

CORINI:	JSR	PC,CORCLR	;FIRST CLEAR TABLES AND FREE CORE AREA
	MOV	#FRECOR,R0	;STARTING ADDRESS OF FREE LIST
	JSR	R5,CORI10	;INITIALIZE SMALL BUFFER LIST
	+	FREES		;LIST CONTROL ADDRESS
	+	32.		;# BYTES PER BUFFER
	+	SMLBUF		;# BUFFERS TO SET UP
				;R0 NOW HAS FIRST UNUSED LOCATION
	JSR	R5,CORI10	;NOW SET UP BIG BUFFER LIST
	+	FREEB		;BIG BUFFER LIST CONTROL
	+	512.		;# BYTES PER BIG BUFFER
	+	BIGBUF		;# BIG BUFFERS IN LIST
	MOV	R0,FREND	;SAVE FOR PERUSAL
	COM	CORTBL+KCORE+KCORE	;TERMINATE CORTBL WITH A -1
	COM	JBSTAT-2	;END JOBTBL WITH A -1
	RTS	PC		;AND RETURN

FREND:	0			;FIRST UNUSED LOCATION IN FREE LIST

;THIS ROUTINE SETS UP LINKED LIST-----------------------------------------
;OF BUFFERS.  A POINTER TO THE FIRST LOCATION------------------------------
;IN THE LIST IS PROVIDED IN R0, AND ON RETURN R0 CONTAINS THE---------------
;FIRST LOCATION UNUSED BY THE LIST.  CALL WITH:
;
;	JSR	R5,CORI10	;R0=FIRST LOCATION TO USE
;	+	ARG1		;ADDRESS OF LIST CONTROL PARAMETERS
;	+	ARG2		;# BYTES PER BUFFER
;	+	ARG3		;# BUFFERS IN CHAIN

CORI10:	MOV	(R5)+,R1	;LIST PARAMETER POINTER
	MOV	(R5)+,R2	;# BYTES PER BUFFER
	MOV	(R5)+,R3	;# BUFFERS IN LIST
	BEQ	CORI11		;IF NONE, THAT'S A SPECIAL CASE
	MOV	R0,(R1)+	;PUT ADDRESS OF FIRST BLOCK IN LIST CONTROL
	MOV	R3,(R1)		;AND BUFFER COUNT TO PARAMETER+2
CORI13:	MOV	R0,R4		;SAVE THE BLOCK ADDRESS
	ADD	R2,R0		;AND GET ADDRESS OF NEXT BLOCK
	MOV	R0,(R4)		;AND STORE ADDRESS OF NEXT IN THIS BLOCK
	SOB	R3,CORI13	;AND CONTINUE
	CLR	(R4)		;THAT LAST POINTER WAS A MISTAKE
	RTS	R5		;RETURN...ALL DONE

CORI11:	CLR	(R1)+		;LIST POINTER = 0
	CLR	(R1)		;LIST COUNT = 0
	RTS	R5		;AND RETURN
;ROUTINE TO CLEAR TABLE AND FREE CORE AREA-----------------------------------

CORCLR:	MOV	#FRECOR,R4	;START OF FREE CORE AREA
	MOV	#SMLBUF,R5	;# SMALL BUFFERS
CORCL1:	ADD	#32.,R4		;ADD IN AREA OF ONE BUFFER
	SOB	R5,CORCL1	;AND REPEAT FOR ALL BUFFERS
	MOV	#BIGBUF,R5	;NOW DO THE BIG BUFFER AREA
	BEQ	CORCL2		;IF THERE ARE ANY....
CORCL3:	ADD	#512.,R4	;THERE ARE
	SOB	R5,CORCL3	;AND CONTINUE
CORCL2:	MOV	#DATA,R5	;NOW CLEAR THE AREA FROM "DATA"
CORCL4:	CLR	(R5)+		;TO THE END WE COMPUTED
	CMP	R5,R4		;AT DATA+32.*SMLBUF+512.*BIGBUF
	BLO	CORCL4		;CONTINUE
	RTS	PC		;DONE

;ROUTINE TO TYPE A MESSAGE TO THE USER---------------------------------
;CALL
;	JSR	R5,MESSAG
;	+	ADDRESS OF STRING, TERMINATED BY 0 BYTE

MESSAG:	MOV	(R5)+,R0	;STRING ADDRESS
MESS01:	MOVB	(R0)+,R2	;CHARACTER TO R2
	BEQ	MESS02		;END OF STRING?
	JSR	PC,INIOUT	;OUTPUT THE CHARACTER IN R2
	BR	MESS01		;AND CONTINUE

MESS02:	RTS	R5		;BACK

;ROUTINE TO OUTPUT A <CR>,<LF>-------------------------------------------

INICR:	MOV	#15,R2		;FIRST THE <CR>
	JSR	PC,INIOUT	;TO THE TTY
	MOV	#12,R2		;AND NOW THE
	JSR	PC,INIOUT	;<LF>
	RTS	PC		;AND RETURN

;ROUTINE TO OUTPUT A CHARACTER IN R2-------------------------------------

INIOUT:	TSTB	TPS		;READY?
	BPL	INIOUT		;NOT YET
	MOV	R2,TPB		;YES-OUTPUT IT
	RTS	PC		;AND BACK
;ROUTINE TO GET INPUT FROM A USER---------------------------------------
;RETURN ON <CR>, ECHO CHARACTER TYPED FOR RUBOUT

GETIN:	MOV	#SYSTAK,R0	;USE FISTAK FOR BUFFER
	MOV	R0,R1		;MARK BEGINNING OF BUFFER
GETI01:	TSTB	TKS		;ANYTHING WAITING?
	BPL	GETI01		;JUST THIS LOOP...
	MOV	TKB,R2		;GET CHARACTER FROM TTY
	BIC	#-177-1,R2	;USE LOW ORDER 7 BITS
	CMPB	R2,#177		;IS IT A RUBOUT?
	BEQ	GETI02		;YES
	CMPB	R2,#40		;IS IT A SPACE?
	BEQ	GETI05		;YES
	CMPB	R2,#15		;IS IT A <CR>?
	BEQ	GETI07		;YES
GETI06:	MOVB	R2,(R0)+	;JUST A PLAIN, OLD CHARACTER, SO STORE IT
GETI03:	JSR	PC,INIOUT	;AND ECHO IT
	BR	GETI01		;AND WAIT SOME MORE

GETI02:	CMP	R0,R1		;IT'S A RUBOUT, ANYTHING IN BUFFER?
	BEQ	GETI04		;NO, SO ECHO CRLF0
	MOVB	-(R0),R2	;GET THE CHARACTER PREVIOUSLY TYPED
	BR	GETI03		;AND ECHO IT

GETI04:	JSR	PC,INICR	;EMPTY BUFFER- ECHO CRLF0
	BR	GETI01		;AND CONTINUE

GETI05:	CMP	R0,R1		;IGNORE LEADING SPACES--IS THIS A LEADING SPACE?
	BEQ	GETI03		;YES-IGNORE IT
	BR	GETI06		;NO-PRESERVE IT

GETI07:	CLRB	(R0)+		;END THE STRING IN BUFFER
	JSR	PC,INICR	;ECHO CRLF0
	RTS	PC		;AND BACK

;INITIALIZE TTY SERVICE---------------------------------------------------

TTINIT:	MOV	#TTILST,R0	;ENABLE KEYBOARD INTERRUPTS
	MOV	#NULINE+1,R1	;FOR ALL KL11 TYPE LINES
TTINI1:	MOV	#101,@(R0)+	;SET INTERRUPT ENABLE AND READER RUN
	SOB	R1,TTINI1	;FOR ALL LINES
	RTS	PC		;AND RETURN


;INITIALIZE QUEUES------------------------------------------------------

QUEINI:	MOV	#L3QUE,R0	;POINT TO L3QUE
	CLR	(R0)+		;CLEAR L3QUE
	CLR	(R0)+		;CLEAR FIQUE
	CLR	(R0)+		;CLEAR DSKQUE
	CLR	(R0)+		;CLEAR DSDONQ
	RTS	PC		;AND RETURN
;INITIALIZE THE FILE SYSTEM
;FIRST CLEAR THE SAT, AND ALLOCATE NON FILE SYSTEM SECTORS OF DISK

FIPINI:	JSR	PC,QUEINI	;SINCE WE USE MONITOR ROUTINES, CLEAR QUEUES
	MOV	#SATBEG,R0	;FIRST CLEAR SAT TABLE
	MOV	R0,SATPTR	;RESET SAT TABLE POINTER
	CLR	SATDEX		;AND INDEX ASSSOCIATED WITH POINTER
FIPI01:	CLR	(R0)+		;FROM THE BEGINNING....
	CMP	R0,#SATEND	;....TO THE END
	BLOS	FIPI01		;UNTIL IT'S ALL CLEAR
	MOV	#RS11,R0	;NO COMPUTE THE # SECTORS WE'VE GOT
	CLR	R1		;IT'S RS11*1024.
FIPI02:	ADD	#1024.,R1	;# SECTORS PER PLATTER
	SOB	R0,FIPI02	;KEEP ADDING
	MOV	R1,SEGCNT	;THAT WOULD BE THE NUMBER...
	MOV	#FIBASE,R3	;	...IF WE DIDN'T NEED SWAP AREAS
FIPI03:	JSR	PC,MKSECT	;BUT WE DO, SO MARK THE SWAP AREA OFF
	DEC	R3		;SECTOR 0 IS SIGNIFICANT
	BPL	FIPI03		;SO CONTINUE UNTIL R3 GOES NEGATIVE
	JSR	PC,FISTIN	;NOW SET UP FISTAK SO NORMAL ROUTINES WORK
	MOV	#INILST,R5	;INITIALIZE THE NON RESIDENT SEGMENTS
	JSR	PC,FIPI20	;BY MARKING THEM IN SAT AND LOADING THEM
	JSR	PC,FIPI30	;NOW GO SET THE NR ENTRY POINTS
	JSR	PC,ERRINI	;AND INITIALIZE THE ERROR FILE
	BR	FIPI06		;AND THEN THE  REST OF THE FILES
;NEXT, GO THROUGH THE DIRECTORIES, AND MARK EACH SEGMENT IN USE IN THE
;SAT. WE KEEP ONE MFD SEGMENT IN FIPBUF (NORMALLY USED FOR NON-RESIDENT CODE)
;AND ONE UFD SEGMENT IN FIBUF, WHICH IS USUALLY USED FOR UFD SEGMENTS;
;THUS THE STANDARD FIP ROUTINES WORK DURING THE INITIALIZATION.
;TO MANIPULATE THE MFD, WE USE SPECIAL REOUTINES, WHICH ARE AVAILABLE ONLY
;AT INIT TIME
FIPI06:	MOV	#1,R2		;READ SEGMENT # 1 . . .
	JSR	R5,PARSET	;	. . .INTO . . .
	+	RFUN		;		. . .THE . . .
	+	FIPBUF		;			. . . BUFFER
	CLR	MFLOG		;LOGICAL MFD INDEX IN BUFFER = 0
	CLR	FIBSTA		;BUFFER STATUS = UNALTERED
	MOV	FIPBUF,R0	;GET MFD ADDRESS OF FIRST ENTRY
FIPI16:	JSR	PC,GETMFL	;GET THE MFD LINK IN CORE
	MOV	(R0),-(SP)	;SAVE MFD ADDRESS OF NEXT BLOCK
	TSTB	USTAT(R0)	;IS IT REALLY A UFD ENTRY OR [1,1] FILE?
	BLE	FIPI15		;IT'S NOT A UFD! SKIP IT
	MOV	UAR(R0),R2	;GET START BLOCK OF UFD
	JSR	PC,READ		;AND READ IT INTO FIBUF
	MOV	#10,R5		;GET SET TO MARK 8 UFD SEGMENTS
	MOV	#UFDEX,R4	;STARTING WITH FIRST IN DESCRIPTOR
FIPI04:	MOV	(R4)+,R3	;GET SEGMENT # FROM DESCRIPTOR
	BEQ	FIPI05		;IF ZERO, WE'VE REACHED THE END
	JSR	PC,MKSEG	;MARK THE SEGMENT IN USE
	SOB	R5,FIPI04	;CONTINUE
FIPI05:	CMP	UFDEX,#1	;IS THIS THE MFD WE HAVE?
	BEQ	FIPI15		;YES- DON'T CHASE THROUGH IT
	MOV	FIBUF,R0	;NO - GET UFD ADDRESS OF FIRST ENTRY
	BEQ	FIPI15		; IF 0, THEN WE'RE DONE
FIPI14:	JSR	PC,GETLNK	;GET FIRST NAME BLOCK
	MOV	(R0),-(SP)	;SAVE ADDRESS OF NEXT UFD NAME BLOCK
	TSTB	UACNT(R0)	;CLEAR ACCESS COUNT
	BEQ	FIPI07		;BUT ONLY IF NECESSARY
	CLRB	UACNT(R0)	;IT IS NECESSARY
FIPI09:	MOV	SP,FIBSTA	;NOTE BUFFER IS ALTERED
FIPI07:	TSTB	USTAT(R0)	;MARKED FOR DELETION?
	BPL	FIPI08		;IF IT WAS . . .
	BICB	#200,USTAT(R0)	;	. . . IT HAS A NEW LIFE
	BR	FIPI09		;FORCE BUFFER OUT
FIPI08:	MOV	UAR(R0),R0	;GET THE UFD ADDRESS OF THE RETRIEVAL BLOCK
FIPI12:	JSR	PC,GETLNK	;GET THE RETRIEVAL BLOCK
	BIT	#1,(R0)		;FILE OF 0 LENGTH??
	BNE	FIPI10		;YES--DON'T TOUCH IT; NOTHING TO MARK
	MOV	R0,R5		;POINTER TO WINDOW
	MOV	#7,R4		;COUNTER OF SEGMENTS TO MARK
	TST	(R5)+		;SKIP OVER LINK TO NEXT BLOCK
FIPI11:	MOV	(R5)+,R3	;GET SEGMENT #
	BEQ	FIPI10		;WE'RE DONE
	JSR	PC,MKSEG	;MARK SEGMENT IN USE
	SOB	R4,FIPI11	;CONTINUE UNTIL END OF BLOCK OR FILE
	MOV	(R0),R0		;GET LINK TO NEXT BLOCK
	BNE	FIPI12		;IF NON-ZERO, CONTINUE MARKING
FIPI10:	MOV	(SP)+,R0	;ONTO THE NEXT FILE
	BNE	FIPI14		;IF THERE IS A NEXT FILE
FIPI15:	MOV	(SP)+,R0	;THERE ISN'T; ON TO NEXT UFD
	BNE	FIPI16		;IF THERE IS A NEXT UFD
	TST	FIBSTA		;ANYTHING CLEARED?
	BEQ	FIPI13		;NO
	JSR	PC,WRITE	;YES, SO OUT WITH BUFFER FULL
FIPI13:	CLR	FIPSEG		;NOW INITIALIZE A FEW CHOICE ITEMS
	CLR	FIBPHS		;LIKE CONTENTS OF BUFFERS
	MOVB	#-1,FIBLOG	;GUARANTEE NO MATCH
	MOV	#FISTAK,FIPSP	;FOR THE FIRST TIME FIP STARTS
FIPI17:	RTS	PC		;WE'RE DONE!


;THIS ROUTINE COPIES THE NON-RESIDENT CODE------------------------------
;ONTO ITS FINAL RESTING PLACE

FIPI20:	MOV	(R5),R3		;ALLOCATE THE SEGMENT
	BEQ	FIPI17		;ALL DONE
	JSR	PC,MKSEG	;BY MARKING IT IN SAT
	MOV	(R5)+,R2	;FILE SEGMENT #
	MOV	(R5)+,FIPI21	;ADDRESS OF CODE IN INITIALIZATION
	JSR	R5,PARSET	;CALL THE DISK ROUTINE
	+	WFUN		;TO WRITE
FIPI21:	+	0		;THE SEGMENT
	BR	FIPI20		;DO IT AGAIN


;ROUTINE TO SET UP NON RESIDENT ENTRY POINTS,---------------------------
;SINCE THE ASSEMBLER CAN'T DIVIDE BY 2!

FIPI30:	MOV	#NRFTBL+1,R0	;POINT TO HIGH BYTE OF TABLE
	MOV	#NRFENT,R1	;POINTER TO BYTE ENTRY POINTS
FIPI31:	MOV	(R1)+,R3	;GET BYTE DISPLACEMENT
	BMI	FIPI17		;END OF TABLE?
	ASR	R3		;CONVERT TO WORD
	MOVB	R3,(R0)+	;AND SET IN TABLE
	INC	R0		;SKIP NEXT BYTE
	BR	FIPI31		;CONTINUE FOR ALL SEGMENTS
;ROUTINE TO INITIALIZE THE "ERROR FILE"
;ERRORS ARE ASSEMBLED, STARTING AT "ERMSG" AS A BYTE
;STRING, SEPARATED WITH 0 BYTES.  THEY ARE EXPANDED TO
;32 BYTE LONG STRINGS, PADDED WITH 0'S AS NEEDED.
;
;THE ERROR FILE IS A SERIES OF  DISK SEGMENTS, STARTING AT
;"SEGER0" AND CONTINUING AS NEEDED.  ERROR MESSAGE "N" MAY
;BE FOUND BY READING SEGMENT "SEGER0+N/16", AND
;INDEXING INTO THE SEGMENT BY THE REMAINDER OF THE DIVISION

SEGER0	=14			;STARTING SEGMENT OF ERROR FILE

ERRINI:	MOV	#ERMSG,R0	;START OF ERROR PMESSAGE STRING
	MOV	#SEGER0,-(SP)	;START BLOCK OF ERROR FILE
ERRI03:	MOV	#FIBUF,R1	;BUFFER TO UNPACK STRINGS
	MOV	#16.,R4		;# OF UNPACKED MESSAGES/SEGMENT
ERRI02:	MOV	#32.,R5		;# OF CHARACTERS/MESSAGE
ERRI01:	MOVB	(R0)+,(R1)+	;COPY A MESSAGE CHARACTER
	BEQ	ERRI04		;TOO SHORT--PAD WITH 0'S
	SOB	R5,ERRI01	;CONTINUE COPYING STRING
	TSTB	(R0)+		;TOO LONG--SKIP TO 0 BYTE
	BNE	.-2		;AND IGNORE REMAINDER
ERRI05:	TSTB	(R0)		;TWO 0 BYTES ARE EOF
	BEQ	ERRI06		;EOF--DUMP PARTIALLY FILLED SEGMENT
	SOB	R4,ERRI02	;NOT EOF--KEEP COPYING

ERRI06:	MOV	(SP),R3		;ALLOCATE THE SEGMENT IN SAT
	JSR	PC,MKSEG	;SO IT WON'T BE REASSIGNED
	MOV	(SP),R2		;AND NOW DUMP THE UNPACKED MESSAGES
	JSR	R5,PARSET	;AND WRITE
	+	WFUN		;IT ON
	+	FIBUF		;THE DISK
	INC	(SP)		;FOR NEXT FILE SEGMENT WRITTEN
	TSTB	(R0)		;WAS THIS THE LAST SEGMENT?
	BNE	ERRI03		;NOT YET
	TST	(SP)+		;IT WAS--POP SEGMENT #
	RTS	PC		;AND BACK TO CALLER

ERRI04:	DEC	R1		;MOVE POINTER BACK
	CLRB	(R1)+		;AND PAD WITH 0'S
	SOB	R5,ERRI04+2	;UNTIL NEXT SLOT IN FILE
	BR	ERRI05		;WAS THIS THE LAST ONE?
;ROUTINE TO GET THE MFD LINK ADDRESSED BY R0 INTO CORE
;ON RETURN, R0 IS ABSOLUTE BUFFER ADDRESS OF LINK
;C.F.GETLNK

GETMFL:	MOV	R0,-(SP)	;SAVE MFD ADDRESS
	BIC	#-777-1,(SP)	;CLEAR ALL BUT LOW ORDER
	SWAB	R0		;DIVIDE BY 2^8
	BIC	#-16-1,R0	;CLEAR ALL BUT LOW ORDER
	CMPB	R0,MFLOG	;IS MFD SEGMENT IN FIPBUF?
	BEQ	GETM01		;YES--EASY, WASN'T IT
	MOVB	R0,MFLOG	;SET LOGICAL INDEX TO THIS ONE
	MOV	FIPBUF+760(R0),R2	;GET PHYSICAL SEGMENT #
	BNE	GETM02		;IF IT'S 0, WE'RE IN TROUBLE
	HALT			;BOY, THAT'S TROUBLE

GETM02:	JSR	R5,PARSET	;NOW READ IN NEXT SEGMENT
	+	RFUN		;READ...
	+	FIPBUF		;    ... INTO FIPBUF

GETM01:	MOV	#FIPBUF,R0	;NOW COMPUTE BUFFER ADDRESS
	ADD	(SP)+,R0	;OFFSET INTO BUFFER
	RTS	PC		;AND RETURN


;ROUTINE TO MARK A FILE SEGMENT IN USE-------------------------------
;SEGMENT # IS IN R3
;THIS PERFORMS THE COMPLEMENT OBVERSE OF THE EXCLUSIVE AND OF
;GETSEG AND RETSEG

MKSEG:	ADD	#FIBASE,R3	;CONVERT TO SECTOR #
	JSR	PC,MKSECT	;AND MARK SECTOR
	RTS	PC		;WASN'T THAT SIMPLE

;ROUTINE TO MARK A DISK SECTOR IN USE----------------------------------
;SEGMENT # IN R3

MKSECT:	MOV	R3,-(SP)	;SAVE R3 FOR RETURN
	DEC	SEGCNT		;UPDATE COUNT
	MOV	R3,R2		;FOR DIVISION
	BIC	#-7-1,R2	;REMAINDER OF SECTOR/8
	CLC			;WE WOULDN'T WANT CARRY AROUND NOW
	ROR	R3		;DIVIDE BY 8
	ASR	R3		;ALMOST THERE
	ASR	R3		;MADE IT
	BITB	RETBIT(R2),SATBEG(R3)	;SEE IF IT'S SET ALREADY..
	BEQ	.+4		;NO PROBLEM
	0003			;THE BUG IS DETECTED!!!!! CALL DEC
	BISB	RETBIT(R2),SATBEG(R3)	;MARK SEGMENT IN SAT
	MOV	(SP)+,R3	;RESTORE R3
	RTS	PC		;AND RETURN


;INITIALIZATION DATA AREA----------------------------------------------

MFLOG:	.WORD	0		;LOGICAL SEGMENT OF MFD IN FIPBUF
;ROUTINE TO REFRESH THE DISK
;WE WRITE AN NEW MFD AND LIBRARY UFD [1,1] AND [1,2], RESPECTIVELY

REFRSH:	JSR	R5,MESSAG	;DOES HE MEAN IT?
	+	REFMES		;"ARE YOU SURE YOU WANT TO REFRESH?"
	JSR	PC,GETIN	;WAIT FOR RESPONSE
	CMPB	(R1),#'Y	;DID HE SAY YES?
	BNE	REFR02		;NO, SO DON'T
	JSR	PC,REFR10	;GO CLEAR FIBUF
	MOV	#MFD0,R0	;AND COPY VIRGIN DIRECTORY TO FIBUF
	MOV	#33.,R1		;# WORDS TO COPY
	MOV	#FIBUF,R2	;WHERE TO COPY THEM INOT
REFR01:	MOV	(R0)+,(R2)+	;COPY A WORD
	SOB	R1,REFR01	;AND ANOTHER AND ANOTHER UNTIL DONE
	MOV	#1,R2		;THIS IS SEGMENT # 1
	MOV	R2,UFDEX	;SO PUT IT IN UFD DESCRIPTOR
	JSR	PC,FISTIN	;SET UP STACK FOR PARSET OPERATION
	JSR	R5,PARSET	;AND WRITE IT OUT
	+	WFUN		;TO SEGMENT #1
	+	FIBUF		;FROM FIBUF
	JSR	PC,REFR10	;NOW CLEAR FIBUF AGAIN
	MOV	#2,R2		;THIS TIME WRITE A LIBRARY UFD
	MOV	R2,UFDEX	;INTO SEGMENT # 2
	COM	FIBUF+2		;MARKER FOR DUMMY NAME BLOCK
	JSR	R5,PARSET	;WRITE IT OUT
	+	WFUN		;TO SEGMENT # 2
	+	FIBUF		;FROM FIBUF
	MOV	#PR7,PS		;DISABLE INTERRUPTS
REFR02:	RTS	PC		;THAT'S ALL THERE IS TO IT

REFR10:	MOV	#FIBUF,R0	;ROUTINE CLEARS FIBUF--------------------
	MOV	#256.,R1	;ALL 256. WORDS OF IT
REFR11:	CLR	(R0)+		;CLEAR THE WORD
	SOB	R1,REFR11	;CONTINUE UNTIL ITS NICE AND CLEAN
	RTS	PC		;YOU CAN GO HOME NOW

;ROUTINE TO MAKE FISTAK LOOK LIKE SYSTAK, SO NULJOB WORKS RIGHT-------------
;WHEN DISK IS IN OPERATION DURING INIT
FISTIN:	CLR	PS		;DISK ROUTINE USES INTERRUPTS
	JSR	PC,QUEINI	;SET UP QUEUES
	MOV	#FISTAK,R5	;WE HAVE TO SET UP AN ALTERNATE STACK
	CLR	-(R5)		;FOR WAITING...PS = 0
	MOV	#NULJOB,-(R5)	;OLD PC = NULJOB
	CLR	-(R5)		;R5 - R0 = 0
	CLR	-(R5)
	CLR	-(R5)		;R3=0
	CLR	-(R5)	
	CLR	-(R5)		;R1=0
	CLR	-(R5)		;R0
	MOV	R5,FIPR6	;MAKE FIP THINK THIS IS OLD SYSTAK VALUE
	RTS	PC		;AND RETURN
;VIRGIN MFD FOR [1,1]
;REFRESH WILL MOVE THIS TO SEGMENT # 1

;-----------------------;FIRST BLOCK
MFD0:	MFD1-MFD0	;POINTER TO FIRST REAL ENTRY
	-1		;MARKER FOR DUMMY BLOCK
	0		;SIX EMPTY WORDS
	0
	0
	0
	0
	0
;-----------------------;START OF SECOND BLOCK
MFD1:	MFD3-MFD0	;FIRST REAL NAME BLOCK
	.BYTE 1,1	;PROJECT-PROGRAMMER # = [1,1]
	.WORD 50557	;.RAD50	/MAG/  PASSWORD IS "MAGI" FOR NOW
	.WORD	34100	;.RAD50 /I  /
	100		;STATUS = UFD
	0		;SPARE
	MFD2-MFD0	;UFD ADDRESS OF ACCOUNTING BLOCK
	1		;STARTING SEGMENT OF UFD
;-----------------------;START OF THIRD BLOCK
MFD2:	-1		;ACCOUNTING BLOCK MARKER
	0		;CPU TIME
	0		;CONNECT TIME
	0		;DEVICE TIME
	0		;KCT'S
	0		;# SEGMENTS OWNDD
	0		;# SEGMENTS PERMITTED
	0		;SPARE
;-----------------------;START OF FOURTH BLOCK
MFD3:	0		;POINTER TO NEXT UFD (NONE YET)
	.BYTE  2, 1	;[1,2] PPN---PROJECT # IS HIGH BYTE
	.WORD 46152	;.RAD50 /LIB/  PASSWORD IS "LIBR"
	.WORD 70200	;.RAD50 /R  /   A LA TSS-8
	100		;STATUS=100 [UFD]
	0		;SPARE
	MFD4-MFD0	;UFD ADDRESS OF ACCOUNTING BLOCK
	2		;STARTING SEGMENT OF UFD
;-----------------------;START OF FIFTH BLOCK
MFD4:	-1		;MARK ACCOUNTING BLOCK
	0		;REST HS SAME AS [1,1]'S ACCOUNTING DATA
	0
	0
	0
	0
	0
	0
	0
INILST:	+	3		;SEGMENTS TO ALLOCATE AND LOAD
	+	CREATE		;CREATE,RENAME,PASSWORD
	+	4
	+	DIRECT		;DIRECT,PROTECT,LOGIN,ERRFIL
	+	5
	+	OPEN		;OPEN
	+	6
	+	GARBAG		;GARBAGE COLLECTOR
	+	7
	+	CLOSE		;CLOSE, DELETE, LOGOUT, RESET, ETC.
	+	10
	+	GARBAG+1000	;SECOND HALF OF GARBAGE COLLECTOR
	+	11
	+	SCAN00		;COMMAND STRING INTERPRETER SEGMENT
	+	12
	+	HEINZ		;ENTRY POINT FOR CATSUP
	+	13
	+	CAJOBO		;CORE ALLOCATOR
	+	0		;END THE LIST

NRFENT	=	.		;BYTE OFFSET TABLE
	+	DELETE-CLOSE	;DELETE
	+	CLOSE-CLOSE	;CLOSE
	+	OPEN-OPEN	;OPEN
	+	CREATE-CREATE	;CREATE
	+	RENAME-CREATE	;RENAME
	+	LOGIN-DIRECT	;LOGIN
	+	LOGOUT-CLOSE	;LOGOUT
	+	DIRECT-DIRECT	;DIRECT
	+	UUOF-DIRECT	;UUOCON
	+	PASSWD-CREATE	;PASS WORD
	+	ERRFIL-DIRECT	;ERROR MESSAGE
	+	GARBAG-GARBAG	;GARBAGE COLLECTOR
	+	CALC-CAJOBO	;CORE ALLOCATOR
	+	ASSIGN-OPEN	;ASSIGN DEVICE
	+	DEAS00-OPEN	;DEASSIGN DEVICE
	+	RESET-CLOSE	;RESET ALL CHANNELS
	+	DEALL-CLOSE	;DEASSIGN ALL
	+	SCAN-SCAN00	;PARSE FILE NAME
	+	HEINZ-HEINZ	;RELATIVE ENTRY POINT
	+	SAVOK-DIRECT	;SAVE FILE OK?
	+	DELNAM-DIRECT	;DELETE BY NAME
	+	UNSF00-DIRECT	;UNSAVE FILE
	+	OLDF-CREATE	;OLD FOO.BAS
	+	RUNF-CREATE	;RUN FOO.BAC
	+	DLUF-DIRECT	;DELETE USER
	+	RADF-DIRECT	;READ ACCOUNTING DATA
	+	WADF-DIRECT	;WRITE ACCOUNTING DATA
	+	CRTMP-CREATE	;CREATE A .TMP FILE WITH UNIQUE NAME
	-	1		;END THE LIST
;INITIALIZATION MESSAGES----------------------------------------

INIMES:	.BYTE	15,12
	.ASCII	/L D R S O ? /
	.BYTE	0
LOGMES:	.ASCII	/[1,2]? /
	.BYTE	0

REFMES:	.ASCII	/SURE? /
	.BYTE	0
AIRMES:	.BYTE	15,12,12	;SPACE UP A FEW LINES
	.ASCII	/RSTS-11  V01C-00/
	.BYTE	15,12,12,0
;MESSAGES FOR TIME AND DATE INITIALIZATION-------

TIMESG:	.ASCII	/HH:MM? /
	.BYTE	0
DAYMES:	.ASCII	/DD-MON-YY? /
	.BYTE	0
DAYBAD:	.ASCII	/BAD DATE!/
	.BYTE	15,12,0
LIEMES:	.ASCII	/PDP-11 BORN IN 1970--TRY AGAIN/
	.BYTE	15,12,0
	.EVEN			;JUST IN CASE--


;EEEEEEEEEEEEEEE   RRRRRRRRRRRR      MMM         MMM      SSSSSSSSSSSS      GGGGGGGGGGGG
;EEEEEEEEEEEEEEE   RRRRRRRRRRRR      MMM         MMM      SSSSSSSSSSSS      GGGGGGGGGGGG
;EEEEEEEEEEEEEEE   RRRRRRRRRRRR      MMM         MMM      SSSSSSSSSSSS      GGGGGGGGGGGG
;EEE               RRR         RRR   MMMMMM   MMMMMM   SSS               GGG
;EEE               RRR         RRR   MMMMMM   MMMMMM   SSS               GGG
;EEE               RRR         RRR   MMMMMM   MMMMMM   SSS               GGG
;EEE               RRR         RRR   MMM   MMM   MMM   SSS               GGG
;EEE               RRR         RRR   MMM   MMM   MMM   SSS               GGG
;EEE               RRR         RRR   MMM   MMM   MMM   SSS               GGG
;EEEEEEEEEEEE      RRRRRRRRRRRR      MMM         MMM      SSSSSSSSS      GGG
;EEEEEEEEEEEE      RRRRRRRRRRRR      MMM         MMM      SSSSSSSSS      GGG
;EEEEEEEEEEEE      RRRRRRRRRRRR      MMM         MMM      SSSSSSSSS      GGG
;EEE               RRR   RRR         MMM         MMM               SSS   GGG   GGGGGGGGG
;EEE               RRR   RRR         MMM         MMM               SSS   GGG   GGGGGGGGG
;EEE               RRR   RRR         MMM         MMM               SSS   GGG   GGGGGGGGG
;EEE               RRR      RRR      MMM         MMM               SSS   GGG         GGG
;EEE               RRR      RRR      MMM         MMM               SSS   GGG         GGG
;EEE               RRR      RRR      MMM         MMM               SSS   GGG         GGG
;EEEEEEEEEEEEEEE   RRR         RRR   MMM         MMM   SSSSSSSSSSSS         GGGGGGGGG
;EEEEEEEEEEEEEEE   RRR         RRR   MMM         MMM   SSSSSSSSSSSS         GGGGGGGGG
;EEEEEEEEEEEEEEE   RRR         RRR   MMM         MMM   SSSSSSSSSSSS         GGGGGGGGG




;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPP         PPP      111111            111111
;PPP         PPP      111111            111111
;PPP         PPP      111111            111111
;PPP         PPP         111               111
;PPP         PPP         111               111
;PPP         PPP         111               111
;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                  111111111         111111111
;PPP                  111111111         111111111
;PPP                  111111111         111111111



;EEEEEEEEEEEEEEE   RRRRRRRRRRRR      MMM         MMM      SSSSSSSSSSSS      GGGGGGGGGGGG
;EEEEEEEEEEEEEEE   RRRRRRRRRRRR      MMM         MMM      SSSSSSSSSSSS      GGGGGGGGGGGG
;EEEEEEEEEEEEEEE   RRRRRRRRRRRR      MMM         MMM      SSSSSSSSSSSS      GGGGGGGGGGGG
;EEE               RRR         RRR   MMMMMM   MMMMMM   SSS               GGG
;EEE               RRR         RRR   MMMMMM   MMMMMM   SSS               GGG
;EEE               RRR         RRR   MMMMMM   MMMMMM   SSS               GGG
;EEE               RRR         RRR   MMM   MMM   MMM   SSS               GGG
;EEE               RRR         RRR   MMM   MMM   MMM   SSS               GGG
;EEE               RRR         RRR   MMM   MMM   MMM   SSS               GGG
;EEEEEEEEEEEE      RRRRRRRRRRRR      MMM         MMM      SSSSSSSSS      GGG
;EEEEEEEEEEEE      RRRRRRRRRRRR      MMM         MMM      SSSSSSSSS      GGG
;EEEEEEEEEEEE      RRRRRRRRRRRR      MMM         MMM      SSSSSSSSS      GGG
;EEE               RRR   RRR         MMM         MMM               SSS   GGG   GGGGGGGGG
;EEE               RRR   RRR         MMM         MMM               SSS   GGG   GGGGGGGGG
;EEE               RRR   RRR         MMM         MMM               SSS   GGG   GGGGGGGGG
;EEE               RRR      RRR      MMM         MMM               SSS   GGG         GGG
;EEE               RRR      RRR      MMM         MMM               SSS   GGG         GGG
;EEE               RRR      RRR      MMM         MMM               SSS   GGG         GGG
;EEEEEEEEEEEEEEE   RRR         RRR   MMM         MMM   SSSSSSSSSSSS         GGGGGGGGG
;EEEEEEEEEEEEEEE   RRR         RRR   MMM         MMM   SSSSSSSSSSSS         GGGGGGGGG
;EEEEEEEEEEEEEEE   RRR         RRR   MMM         MMM   SSSSSSSSSSSS         GGGGGGGGG




;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPP         PPP      111111            111111
;PPP         PPP      111111            111111
;PPP         PPP      111111            111111
;PPP         PPP         111               111
;PPP         PPP         111               111
;PPP         PPP         111               111
;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPPPPPPPPPPP            111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                     111               111
;PPP                  111111111         111111111
;PPP                  111111111         111111111
;PPP                  111111111         111111111

;ERROR MESSAGES (WRITTEN ON DISK BY ERRINI)
;ERROR CODES 0-NOLINE ARE TYPED AS
;	"ERROR" AT LINE XXX
;ERROR CODES > NOLINE ARE TYPED WITHOUT LINE #
;
;ERROR CODES 0-ERRCC ARE RECOVERABLE ERRORS. IF THE USER HAS EXECUTED
;AN "ON ERROR GOTO..." STATEMENT, THESE ARE THE ONES HE GETS TO HANDLE

	.MACR	$ERR	QQ1,QQ2		;NON FATAL ERROR DEFINITION
QQ1	=TRAP  !  ERRCNT
	ERRCNT =  ERRCNT+1
	.ASCII	  %'QQ2'%
	.BYTE	  0
	.ENDM

	.MACR	$ERRF	QQ1,QQ2		;FATAL ERRORS
QQ1	=TRAP ! FATAL ! ERRCNT
	ERRCNT =  ERRCNT+1
	.ASCII	%'QQ2'%
	.BYTE	  0
	.ENDM

;MISCELLANEOUS DEFINITIONS

ERRCNT	=	0			;INITIAL ERROR CODE
FATAL	=	200			;MASK FOR FATAL ERRORS
POST	=	TRAP			;FLOATING ERRORS SET IN JDFLG
PSTFLT	=	2!JFSTOP		;FLOATING ERRORS SET IN JDFLG
PSTLOG	=	4!JFSTOP		;LOG ERROR
PSTSQR	=	6!JFSTOP		;SQRT ERROR
PSTFIX	=	10!JFSTOP		;FIX ERROR
PSTDV0	=	12!JFSTOP		;DIVISION BY 0.
	.=	DATA		;STORE THE ERROR MESSAGES IN THE FREE CORE AREA
ERMSG	=	.
$ERR	NONERR,			^%RSTS-11  V01C-00 SYS #213%
$ERR	IOTERR,			^%BAD DIRECTORY FOR DEVICE%
$ERR	.IO.,			^%ILLEGAL FILE NAME%
$ERR	.IO.,			^%FILE IS CURRENTLY OPEN%
$ERR	.IO.,			^%NO ROOM ON DEVICE%
$ERR	.IO.,			^%CAN'T FIND FILE%
$ERR	.IO.,			^%NOT A VALID DEVICE%
$ERR	.IO.,			^%I/O CHANNEL ALREADY OPEN%
$ERR	.IO.,			^%DEVICE NOT AVAILABLE%
$ERR	NOPERR,			^%I/O CHANNEL NOT OPEN%
$ERR	RPERR,			^%PROTECTION VIOLATION%
	WPERR	=		RPERR
$ERR	.IO.,			^%END OF FILE ON DEVICE%
$ERR	.IO.,			^%OPERATION ABORTED%
$ERR	.IO.,			^%DATA ERROR ON DEVICE%
$ERR	.IO.,			^%DEVICE OK?%
$ERR	.IO.,			^%TELETYPE WAIT EXHAUSTED%
$ERR	.IO.,			^%FILE OF SAME NAME EXISTS%
	OPNERR	=		IOTERR
	OPIERR	=		IOTERR
$ERRF	VCAERR,			^%VIRTUAL CORE NOT ON DISK%
$ERRF	SIZERR,			^%VIRTUAL CORE EXCEEDED%
$ERRF	VCOERR,			^%VIRTUAL ARRAY NOT OPENED%
$ERRF	BSERR,			^%ILLEGAL I/O CHANNEL%
$ERR	LINERR,			^%LINE TOO LONG%
$ERR	FLTERR,			^%FLOATING POINT ERROR%
$ERR	EXPERR,			^%ARGUMENT TOO LARGE IN EXP%
$ERR	SINERR,			^%ARGUMENT TOO LARGE IN SIN%
	DVFERR	=		FLTERR
$ERR	FIXERR,			^%INTEGER ERROR%
$ERR	BDNERR,			^%ILLEGAL NUMBER%
$ERR	LOGERR,			^%TRANSCENDENTAL ERROR%
$ERR	SQRERR,			^%IMAGINARY SQUARE ROOT%
$ERRF	SUBERR,			^%SUBSCRIPT OUT OF RANGE%
$ERRF	ODD,			^%OUT OF DATA%
$ERRF	ONBAD,			^%ON-STATEMENT OUT OF RANGE%
$ERRF	NEDERR,			^%NOT ENOUGH DATA IN RECORD%
$ERR	BADUUO,			^%ILLEGAL UUO FOR USER%
ERRCC	=	ERRCNT		;CAN'T CONTINUE FROM OTHERS
$ERR	XCDCOR,			^%MAXIMUM CORE EXCEEDED%
$ERRF	STMERR,			^%STATEMENT NOT FOUND%
$ERRF	BADERR,			^%ILLEGAL STATEMENT%
$ERR	STPERR,			^%STOP%
$ERRF	ERRERR,			^%UNIMPLEMENTED CODE%
$ERRF	UDMERR,			^%ARRAY WITHOUT DIM%
$ERR	EXITTM,			^%RETURN WITHOUT GOSUB%
$ERR	EXITNR,			^%FNEND WITH OUT FUNCTION CALL%
$ERR	UNDFNI,			^%UNDEFINED FUNCTION CALLED%
$ERRF	COSERR,			^%ILLEGAL SYMBOL%
$ERRF	TLOPNV,			^%ILLEGAL VERB%
	TLILPV	=		TLOPNV
$ERRF	TLNZSP,			^%ILLEGAL EXPRESSION%
	TLNFOF	=		TLNZSP
$ERRF	TLNOIT,			^%ILLEGAL MODE MIXING%
	TLICAT	=		TLNOIT
	TLICDT	=		TLNOIT
$ERRF	TLIFFE,			^%ILLEGAL IF STATEMENT%
$ERRF	TLCONI,			^%ILLEGAL CONDITIONAL CLAUSE%
$ERRF	TLNOTF,			^%ILLEGAL FUNCTION NAME%
	TLQFFN	=		TLNOTF
$ERRF	TLQDUM,			^%ILLEGAL DUMMY VARIABLE%
	TLGADM	=		TLQDUM
$ERRF	TLMFND,			^%ILLEGAL FN REDEFINITION%
$ERRF	TLRNNM,			^%ILLEGAL LINE NUMBER(S)%
	TLRNNL	=		TLRNNM
$ERRF	MODERR,			^%MODIFIER ERROR%
$ERRF	TLORDT,			^%CAN'T COMPILE STATEMENT%
$ERRF	OUTOAS,			^%EXPRESSION TOO COMPLICATED%
$ERRF	FUNERR,			^%ARGUMENTS DON'T MATCH%
	TLPWNE	=		FUNERR
$ERRF	TLTMAF,			^%TOO MANY ARGUMENTS%
	TLDFTM=			TLTMAF
$ERR	TLINCD,			^%INCONSISTENT FUNCTION USAGE%
$ERR	CPNSDF,			^%ILLEGAL DEF NESTING%
$ERR	CPUPFR,			^%FOR WITHOUT NEXT%
$ERR	CPUFNX,			^%NEXT WITHOUT FOR%
$ERR	CPUPDF,			^%DEF WITHOUT FNEND%
$ERR	CPUPED,			^%FNEND WITHOUT DEF%
$ERRF	TLJNKY,			^%CONSTANT STRING NEEDED%
$ERRF	TLNOFN,			^%TOO FEW ARGUMENTS%
$ERRF	SASYNE,			^%SYNTAX ERROR%
	PHSOAS=		SASYNE
$ERRF	SAFNOS,			^%STRING IS NEEDED%
$ERRF	TLTRNK,			^%TEXT TRUNCATED%
$ERRF	SASNOI,			^%NUMBER IS NEEDED%
$ERRF	TLURTP,			^%DATA TYPE ERROR%
$ERRF	TLXDIM,			^%1 OR 2 DIMENSIONS ONLY%
$ERRF	FUCORE,			^%PROGRAM LOST-SORRY%
$ERR	RESERR,			^%RESUME AND NO ERROR%
$ERRF	DIMED2,			^%REDIMENSIONED ARRAY%
$ERR	TLIDIM,			^%INCONSISTENT SUBSCRIPT USE%
	INCONA	=		TLIDIM
$ERRF	NOGOTO,			^%ON-STATEMENT NEEDS GOTO%
$ERRF	EOSERR,			^%END OF STATEMENT NOT SEEN%
NOLINE	=	ERRCNT		;NO "AT LINE XXX" FOR REST
EDERF	=TRAP!FATAL!ERRCNT-1	;FOR ON-LINE ERROR CALL
$ERRF	.ED.,			^%BAD DIRECTORY FOR DEVICE%
$ERRF	.ED.,			^%ILLEGAL FILE NAME%
$ERRF	.ED.,			^%FILE IS CURRENTLY OPEN%
$ERRF	.ED.,			^%NO ROOM ON DEVICE%
$ERRF	.ED.,			^%CAN'T FIND THAT FILE%
	EDNOPB	=		.ED.
$ERRF	.ED.,			^%CAN'T FIND THAT DEVICE%
$ERR	.ED.,			^%I/O CHANNEL ALREADY OPEN%
$ERRF	.ED.,			^%DEVICE NOT AVAILABLE%
$ERRF	.ED.,			^%I/O CHANNEL NOT OPEN%
$ERRF	.ED.,			^%PROTECTION VIOLATION%
$ERRF	.ED.,			^%END OF FILE ON DEVICE%
$ERRF	.ED.,			^%OPERATION ABORTED%
$ERRF	.ED.,			^%DATA ERROR ON DEVICE%
$ERRF	.ED.,			^%DEVICE OK?%
$ERRF	TLCNTD,			^%WHAT?%
$ERRF	TLPRNM,			^%BAD LINE NUMBER PAIR%
$ERR	EDENDF,			^%NO END STATEMENT IN PROGRAM%
$ERR	EDBMCE,			^%NOT ENOUGH CORE%
$ERRF	EDEXON,			^%EXECUTE ONLY FILE%
$ERRF	EDNOST,			^%STATEMENT NOT FOUND%
$ERRF	NRNERR,			^%PLEASE USE THE RUN COMMAND%
$ERRF	EDCONE,			^%CAN'T CONTINUE%
$ERRF	EDARSV,			^%FILE EXISTS-USE 'REPLACE'%
$ERR	KCOREM,			^%K OF CORE USED%
$ERRF	SWPERR,			^%SWAP ERROR FOR JOB%
$ERRF	LOGNOT,			^%PLEASE SAY HELLO%
$ERRF	NONOIM,			^%ILLEGAL IN IMMEDIATE MODE%
$ERR	TLTRNK,			^%TEXT TRUNCATED%
	.BYTE	0		;END THE FILE
	.EVEN
	.END	INIT


;	   CCCCCCCCCCCC   RRRRRRRRRRRR      EEEEEEEEEEEEEEE   FFFFFFFFFFFFFFF
;	   CCCCCCCCCCCC   RRRRRRRRRRRR      EEEEEEEEEEEEEEE   FFFFFFFFFFFFFFF
;	   CCCCCCCCCCCC   RRRRRRRRRRRR      EEEEEEEEEEEEEEE   FFFFFFFFFFFFFFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRRRRRRRRRRR      EEEEEEEEEEEE      FFFFFFFFFFFF
;	CCC               RRRRRRRRRRRR      EEEEEEEEEEEE       FFFFFFFFFFFF
;	CCC               RRRRRRRRRRRR      EEEEEEEEEEEE      FFFFFFFFFFFF
;	CCC               RRR   RRR         EEE               FFF
;	CCC               RRR   RRR         EEE               FFF
;	CCC               RRR   RRR         EEE               FFF
;	CCC               RRR      RRR      EEE               FFF
;	CCC               RRR      RRR      EEE               FFF
;	CCC               RRR      RRR      EEE               FFF
;	   CCCCCCCCCCCC   RRR         RRR   EEEEEEEEEEEEEEE   FFF
;	   CCCCCCCCCCCC   RRR         RRR   EEEEEEEEEEEEEEE   FFF
;	   CCCCCCCCCCCC   RRR         RRR   EEEEEEEEEEEEEEE   FFF
;	   CCCCCCCCCCCC   RRRRRRRRRRRR      EEEEEEEEEEEEEEE   FFFFFFFFFFFFFFF
;	   CCCCCCCCCCCC   RRRRRRRRRRRR      EEEEEEEEEEEEEEE   FFFFFFFFFFFFFFF
;	   CCCCCCCCCCCC   RRRRRRRRRRRR      EEEEEEEEEEEEEEE   FFFFFFFFFFFFFFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRR         RRR   EEE               FFF
;	CCC               RRRRRRRRRRRR      EEEEEEEEEEEE      FFFFFFFFFFFF
;	CCC               RRRRRRRRRRRR      EEEEEEEEEEEE       FFFFFFFFFFFF
;	CCC               RRRRRRRRRRRR      EEEEEEEEEEEE      FFFFFFFFFFFF
;	CCC               RRR   RRR         EEE               FFF
;	CCC               RRR   RRR         EEE               FFF
;	CCC               RRR   RRR         EEE               FFF
;	CCC               RRR      RRR      EEE               FFF
;	CCC               RRR      RRR      EEE               FFF
;	CCC               RRR      RRR      EEE               FFF
;	   CCCCCCCCCCCC   RRR         RRR   EEEEEEEEEEEEEEE   FFF
;	   CCCCCCCCCCCC   RRR         RRR   EEEEEEEEEEEEEEE   FFF
;	   CCCCCCCCCCCC   RRR         RRR   EEEEEEEEEEEEEEE   FFF
 